7. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 4/3/2018 9:48:47 AM Eastern Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

7.1 Files compared

# Location File Last Modified
1 ESM_V10_DG_53_P941_V10.KID.zip DG_53_P914_V10.KID Fri Mar 30 14:04:16 2018 UTC
2 ESM_V10_DG_53_P941_V10.KID.zip DG_53_P914_V10.KID Fri Mar 30 20:53:04 2018 UTC

7.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 0 0
Changed 1 14
Inserted 0 0
Removed 0 0

7.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

7.4 Active regular expressions

No regular expressions were active.

7.5 Comparison detail

  1   KIDS Distr ibution sa ved on Jan  23, 2018@ 13:18:33ES M CAMP LEJ EUNE**KIDS **:DG*5.3* 914^PX*1.0 *207^SD*5. 3*631^**IN STALL NAME **DG*5.3*9 14"BLD",92 35,0)DG*5. 3*914^REGI STRATION^0 ^3180123^y "BLD",9235 ,1,0)^^1^1 ^3171205^" BLD",9235, 1,1,0)Plea se refer t o the patc h descript ion for de tails."BLD ",9235,4,0 )^9.64PA^4 05^3"BLD", 9235,4,45, 0)45"BLD", 9235,4,45, 2,0)^9.641 ^45.02^2"B LD",9235,4 ,45,2,45,0 )PTF  (Fil e-top leve l)"BLD",92 35,4,45,2, 45,1,0)^9. 6411^79.33 ^1"BLD",92 35,4,45,2, 45,1,79.33 ,0)TREATME NT FOR CAM P LEJEUNE" BLD",9235, 4,45,2,45. 02,0)501   (sub-file) "BLD",9235 ,4,45,2,45 .02,1,0)^9 .6411^33^1 "BLD",9235 ,4,45,2,45 .02,1,33,0 )TREATMENT  FOR CAMP  LEJEUNE"BL D",9235,4, 45,222)y^y ^p^^^^n^^n "BLD",9235 ,4,45,224) "BLD",9235 ,4,46.1,0) 46.1"BLD", 9235,4,46. 1,2,0)^9.6 41^46.1^1" BLD",9235, 4,46.1,2,4 6.1,0)INPA TIENT POV   (File-top  level)"BL D",9235,4, 46.1,2,46. 1,1,0)^9.6 411^.1^1"B LD",9235,4 ,46.1,2,46 .1,1,.1,0) TREATMENT  FOR CAMP L EJEUNE"BLD ",9235,4,4 6.1,222)y^ y^p^^^^n^^ n"BLD",923 5,4,46.1,2 24)"BLD",9 235,4,405, 0)405"BLD" ,9235,4,40 5,2,0)^9.6 41^405^1"B LD",9235,4 ,405,2,405 ,0)PATIENT  MOVEMENT   (File-top  level)"BL D",9235,4, 405,2,405, 1,0)^9.641 1^29^1"BLD ",9235,4,4 05,2,405,1 ,29,0)TREA TMENT FOR  CAMP LEJEU NE"BLD",92 35,4,405,2 22)y^y^p^^ ^^n^^n"BLD ",9235,4,4 05,224)"BL D",9235,4, "APDD",45, 45)"BLD",9 235,4,"APD D",45,45,7 9.33)"BLD" ,9235,4,"A PDD",45,45 .02)"BLD", 9235,4,"AP DD",45,45. 02,33)"BLD ",9235,4," APDD",46.1 ,46.1)"BLD ",9235,4," APDD",46.1 ,46.1,.1)" BLD",9235, 4,"APDD",4 05,405)"BL D",9235,4, "APDD",405 ,405,29)"B LD",9235,4 ,"B",45,45 )"BLD",923 5,4,"B",46 .1,46.1)"B LD",9235,4 ,"B",405,4 05)"BLD",9 235,6)8^"B LD",9235,6 .3)104"BLD ",9235,"AB PKG")n"BLD ",9235,"KR N",0)^9.67 PA^779.2^2 0"BLD",923 5,"KRN",.4 ,0).4"BLD" ,9235,"KRN ",.401,0). 401"BLD",9 235,"KRN", .402,0).40 2"BLD",923 5,"KRN",.4 02,"NM",0) ^9.68A^13^ 12"BLD",92 35,"KRN",. 402,"NM",1 ,0)DG101     FILE #45 ^45^0"BLD" ,9235,"KRN ",.402,"NM ",2,0)DG10 1F    FILE  #45^45^0" BLD",9235, "KRN",.402 ,"NM",4,0) DG501    F ILE #45^45 ^0"BLD",92 35,"KRN",. 402,"NM",5 ,0)DG501F     FILE #4 5^45^0"BLD ",9235,"KR N",.402,"N M",6,0)DG8 01    FILE  #46.1^46. 1^0"BLD",9 235,"KRN", .402,"NM", 7,0)DGQWK     FILE #4 5^45^0"BLD ",9235,"KR N",.402,"N M",8,0)DGQ WKF    FIL E #45^45^0 "BLD",9235 ,"KRN",.40 2,"NM",9,0 )DG501-10D     FILE # 45^45^0"BL D",9235,"K RN",.402," NM",10,0)D G501F-10D     FILE #4 5^45^0"BLD ",9235,"KR N",.402,"N M",11,0)DG PM ADMIT     FILE #40 5^405^0"BL D",9235,"K RN",.402," NM",12,0)D GPM SPECIA LTY TRANSF ER    FILE  #405^405^ 0"BLD",923 5,"KRN",.4 02,"NM",13 ,0)DGPM AS IH ADMIT     FILE #40 5^405^0"BL D",9235,"K RN",.402," NM","B","D G101    FI LE #45",1) "BLD",9235 ,"KRN",.40 2,"NM","B" ,"DG101F     FILE #45 ",2)"BLD", 9235,"KRN" ,.402,"NM" ,"B","DG50 1    FILE  #45",4)"BL D",9235,"K RN",.402," NM","B","D G501-10D     FILE #45 ",9)"BLD", 9235,"KRN" ,.402,"NM" ,"B","DG50 1F    FILE  #45",5)"B LD",9235," KRN",.402, "NM","B"," DG501F-10D     FILE # 45",10)"BL D",9235,"K RN",.402," NM","B","D G801    FI LE #46.1", 6)"BLD",92 35,"KRN",. 402,"NM"," B","DGPM A DMIT    FI LE #405",1 1)"BLD",92 35,"KRN",. 402,"NM"," B","DGPM A SIH ADMIT     FILE #4 05",13)"BL D",9235,"K RN",.402," NM","B","D GPM SPECIA LTY TRANSF ER    FILE  #405",12) "BLD",9235 ,"KRN",.40 2,"NM","B" ,"DGQWK     FILE #45" ,7)"BLD",9 235,"KRN", .402,"NM", "B","DGQWK F    FILE  #45",8)"BL D",9235,"K RN",.403,0 ).403"BLD" ,9235,"KRN ",.5,0).5" BLD",9235, "KRN",.84, 0).84"BLD" ,9235,"KRN ",3.6,0)3. 6"BLD",923 5,"KRN",3. 8,0)3.8"BL D",9235,"K RN",9.2,0) 9.2"BLD",9 235,"KRN", 9.8,0)9.8" BLD",9235, "KRN",9.8, "NM",0)^9. 68A^71^29" BLD",9235, "KRN",9.8, "NM",2,0)V ADPT0^^0^B 14014645"B LD",9235," KRN",9.8," NM",3,0)VA DPT4^^0^B4 6948271"BL D",9235,"K RN",9.8,"N M",6,0)DGA PI1^^0^B25 401406"BLD ",9235,"KR N",9.8,"NM ",16,0)DGP TF^^0^B248 92539"BLD" ,9235,"KRN ",9.8,"NM" ,17,0)DGPT F1^^0^B432 36092"BLD" ,9235,"KRN ",9.8,"NM" ,18,0)DGPT FM^^0^B845 39163"BLD" ,9235,"KRN ",9.8,"NM" ,19,0)DGPT FM4^^0^B37 164893"BLD ",9235,"KR N",9.8,"NM ",20,0)DGP TFMO^^0^B4 5159824"BL D",9235,"K RN",9.8,"N M",21,0)DG PTFVC1^^0^ B43425692" BLD",9235, "KRN",9.8, "NM",22,0) DGPTR0^^0^ B27460595" BLD",9235, "KRN",9.8, "NM",24,0) DGPTR4^^0^ B22236456" BLD",9235, "KRN",9.8, "NM",25,0) DGPTRI0^^0 ^B27777148 "BLD",9235 ,"KRN",9.8 ,"NM",27,0 )DGPTRI4^^ 0^B7136361 3"BLD",923 5,"KRN",9. 8,"NM",35, 0)DGRPDB^^ 0^B2424012 9"BLD",923 5,"KRN",9. 8,"NM",48, 0)DGPTFM21 ^^0^B15623 829"BLD",9 235,"KRN", 9.8,"NM",5 5,0)DGPTLM U6^^0^B918 5980"BLD", 9235,"KRN" ,9.8,"NM", 57,0)DGPTU TL^^0^B236 20117"BLD" ,9235,"KRN ",9.8,"NM" ,59,0)DGPT FTR^^0^B55 556979"BLD ",9235,"KR N",9.8,"NM ",60,0)DGP TSPQ^^0^B1 4427202"BL D",9235,"K RN",9.8,"N M",61,0)VA FHLZCL^^0^ B4425846"B LD",9235," KRN",9.8," NM",63,0)D GPTRI1^^0^ B46716592" BLD",9235, "KRN",9.8, "NM",64,0) DGUTL3^^0^ B10595349" BLD",9235, "KRN",9.8, "NM",65,0) DGPTRNU^^0 ^B57839149 "BLD",9235 ,"KRN",9.8 ,"NM",66,0 )DGPTR1^^0 ^B31569906 "BLD",9235 ,"KRN",9.8 ,"NM",67,0 )DGENCLEA^ ^0^B230517 10"BLD",92 35,"KRN",9 .8,"NM",68 ,0)DGPTAEE 2^^0^B3339 9825"BLD", 9235,"KRN" ,9.8,"NM", 69,0)DGPTA EE1^^0^B43 310874"BLD ",9235,"KR N",9.8,"NM ",70,0)DGP TFFB^^0^B8 592145"BLD ",9235,"KR N",9.8,"NM ",71,0)DGP TFCLV^^0^B 5398483"BL D",9235,"K RN",9.8,"N M","B","DG API1",6)"B LD",9235," KRN",9.8," NM","B","D GENCLEA",6 7)"BLD",92 35,"KRN",9 .8,"NM","B ","DGPTAEE 1",69)"BLD ",9235,"KR N",9.8,"NM ","B","DGP TAEE2",68) "BLD",9235 ,"KRN",9.8 ,"NM","B", "DGPTF",16 )"BLD",923 5,"KRN",9. 8,"NM","B" ,"DGPTF1", 17)"BLD",9 235,"KRN", 9.8,"NM"," B","DGPTFC LV",71)"BL D",9235,"K RN",9.8,"N M","B","DG PTFFB",70) "BLD",9235 ,"KRN",9.8 ,"NM","B", "DGPTFM",1 8)"BLD",92 35,"KRN",9 .8,"NM","B ","DGPTFM2 1",48)"BLD ",9235,"KR N",9.8,"NM ","B","DGP TFM4",19)" BLD",9235, "KRN",9.8, "NM","B"," DGPTFMO",2 0)"BLD",92 35,"KRN",9 .8,"NM","B ","DGPTFTR ",59)"BLD" ,9235,"KRN ",9.8,"NM" ,"B","DGPT FVC1",21)" BLD",9235, "KRN",9.8, "NM","B"," DGPTLMU6", 55)"BLD",9 235,"KRN", 9.8,"NM"," B","DGPTR0 ",22)"BLD" ,9235,"KRN ",9.8,"NM" ,"B","DGPT R1",66)"BL D",9235,"K RN",9.8,"N M","B","DG PTR4",24)" BLD",9235, "KRN",9.8, "NM","B"," DGPTRI0",2 5)"BLD",92 35,"KRN",9 .8,"NM","B ","DGPTRI1 ",63)"BLD" ,9235,"KRN ",9.8,"NM" ,"B","DGPT RI4",27)"B LD",9235," KRN",9.8," NM","B","D GPTRNU",65 )"BLD",923 5,"KRN",9. 8,"NM","B" ,"DGPTSPQ" ,60)"BLD", 9235,"KRN" ,9.8,"NM", "B","DGPTU TL",57)"BL D",9235,"K RN",9.8,"N M","B","DG RPDB",35)" BLD",9235, "KRN",9.8, "NM","B"," DGUTL3",64 )"BLD",923 5,"KRN",9. 8,"NM","B" ,"VADPT0", 2)"BLD",92 35,"KRN",9 .8,"NM","B ","VADPT4" ,3)"BLD",9 235,"KRN", 9.8,"NM"," B","VAFHLZ CL",61)"BL D",9235,"K RN",19,0)1 9"BLD",923 5,"KRN",19 .1,0)19.1" BLD",9235, "KRN",101, 0)101"BLD" ,9235,"KRN ",101,"NM" ,0)^9.68A^ ^0"BLD",92 35,"KRN",4 09.61,0)40 9.61"BLD", 9235,"KRN" ,771,0)771 "BLD",9235 ,"KRN",779 .2,0)779.2 "BLD",9235 ,"KRN",870 ,0)870"BLD ",9235,"KR N",8989.51 ,0)8989.51 "BLD",9235 ,"KRN",898 9.52,0)898 9.52"BLD", 9235,"KRN" ,8994,0)89 94"BLD",92 35,"KRN"," B",.4,.4)" BLD",9235, "KRN","B", .401,.401) "BLD",9235 ,"KRN","B" ,.402,.402 )"BLD",923 5,"KRN","B ",.403,.40 3)"BLD",92 35,"KRN"," B",.5,.5)" BLD",9235, "KRN","B", .84,.84)"B LD",9235," KRN","B",3 .6,3.6)"BL D",9235,"K RN","B",3. 8,3.8)"BLD ",9235,"KR N","B",9.2 ,9.2)"BLD" ,9235,"KRN ","B",9.8, 9.8)"BLD", 9235,"KRN" ,"B",19,19 )"BLD",923 5,"KRN","B ",19.1,19. 1)"BLD",92 35,"KRN"," B",101,101 )"BLD",923 5,"KRN","B ",409.61,4 09.61)"BLD ",9235,"KR N","B",771 ,771)"BLD" ,9235,"KRN ","B",779. 2,779.2)"B LD",9235," KRN","B",8 70,870)"BL D",9235,"K RN","B",89 89.51,8989 .51)"BLD", 9235,"KRN" ,"B",8989. 52,8989.52 )"BLD",923 5,"KRN","B ",8994,899 4)"BLD",92 35,"QDEF") ^^^^NO^^^^ NO^^NO"BLD ",9235,"QU ES",0)^9.6 2^^"BLD",9 235,"REQB" ,0)^9.611^ 13^6"BLD", 9235,"REQB ",3,0)DG*5 .3*909^1"B LD",9235," REQB",5,0) DG*5.3*653 ^1"BLD",92 35,"REQB", 6,0)DG*5.3 *749^1"BLD ",9235,"RE QB",10,0)D G*5.3*884^ 1"BLD",923 5,"REQB",1 2,0)DG*5.3 *887^1"BLD ",9235,"RE QB",13,0)D G*5.3*935^ 1"BLD",923 5,"REQB"," B","DG*5.3 *653",5)"B LD",9235," REQB","B", "DG*5.3*74 9",6)"BLD" ,9235,"REQ B","B","DG *5.3*884", 10)"BLD",9 235,"REQB" ,"B","DG*5 .3*887",12 )"BLD",923 5,"REQB"," B","DG*5.3 *909",3)"B LD",9235," REQB","B", "DG*5.3*93 5",13)"FIA ",45)PTF"F IA",45,0)^ DGPT("FIA" ,45,0,0)45 IP"FIA",45 ,0,1)y^y^p ^^^^n^^n"F IA",45,0,1 0)"FIA",45 ,0,11)"FIA ",45,0,"RL RO")"FIA", 45,0,"VR") 5.3^DG"FIA ",45,45)1" FIA",45,45 ,79.33)"FI A",45,45.0 2)1"FIA",4 5,45.02,33 )"FIA",46. 1)INPATIEN T POV"FIA" ,46.1,0)^D GICD9(46.1 ,"FIA",46. 1,0,0)46.1 P"FIA",46. 1,0,1)y^y^ p^^^^n^^n" FIA",46.1, 0,10)"FIA" ,46.1,0,11 )"FIA",46. 1,0,"RLRO" )"FIA",46. 1,0,"VR")5 .3^DG"FIA" ,46.1,46.1 )1"FIA",46 .1,46.1,.1 )"FIA",405 )PATIENT M OVEMENT"FI A",405,0)^ DGPM("FIA" ,405,0,0)4 05ID"FIA", 405,0,1)y^ y^p^^^^n^^ n"FIA",405 ,0,10)"FIA ",405,0,11 )"FIA",405 ,0,"RLRO") "FIA",405, 0,"VR")5.3 ^DG"FIA",4 05,405)1"F IA",405,40 5,29)"KRN" ,.402,83,- 1)0^1"KRN" ,.402,83,0 )DG101^318 0109.0729^ ^45^^^3180 116"KRN",. 402,83,"DI AB",1,0,45 ,2)PATIENT  MOVEMENT: "KRN",.402 ,83,"DIAB" ,1,2,2.02, 0).01;"RAC E""KRN",.4 02,83,"DIA B",1,2,2.0 6,0).01;"E THNICITY"" KRN",.402, 83,"DIAB", 2,0,45,1)P ATIENT:"KR N",.402,83 ,"DIAB",4, 1,2,0)6;"E THNICITY"" KRN",.402, 83,"DIAB", 5,1,2,0)2; "RACE""KRN ",.402,83, "DIAB",6,0 ,45,0)SOUR CE OF ADMI SSION;REQ" KRN",.402, 83,"DR",1, 45)S:+DGJU MP'=1 Y="@ 99";@1;S D GJUMP=$P(D GJUMP,"1," ,2);3//^S  X=$P($$SIT E^VASITE,U ,3);5;20R~ ;22;21.1;2 1.2;20.1// //^S X=$$E LIG^DGUTL3 (DFN,1,$P( $G(^DGPT(D A,101)),U, 8));I DGPT FMT>1 S Y= "@10";23;@ 10;S:+DGJU MP'=2 Y="@ 99";@2;@3; @4;"KRN",. 402,83,"DR ",1,45,1)S  DGCLV=DGJ UMP;^2^DPT (^^S I(0,0 )=D0 S Y(1 )=$S($D(^D GPT(D0,0)) :^(0),1:"" ) S X=$P(Y (1),U,1),X =X  S D(0) =+X S X=$S (D(0)>0:D( 0),1:"");S :(+$G(DGCL V)=2)!(+$G (DGCLV)=4)  Y="@99";S :$$GETCL^D GUTL3(DFN) '=1 Y="@39 ";"KRN",.4 02,83,"DR" ,1,45,2)^4 05^DGPM(^^ S I(0,0)=$ G(D0),D0=$ O(^DGPM("A PTF",I(0,0 ),0)) S:$O (^(D0))>0  D0=0 S X=$ S(D0>0:D0, 1:""),D(0) =X S D0=I( 0,0) S X=$ S(D(0)>0:D (0),1:""); @39;S:+DGJ UMP'=5 Y=" @99";@5;S  DGJUMP=$P( DGJUMP,"5, ",2);75;S: +DGJUMP'=6  Y="@99";@ 6;"KRN",.4 02,83,"DR" ,1,45,3)S  DGJUMP=$P( DGJUMP,"6, ",2);73;74 ;S:DGJUMP' =7 Y="@99" ;@7;S DGJU MP=$P(DGJU MP,"7,",2) ;76.1;76.2 ;78;77;@99 ;K DGCLV;S :+DGJUMP Y ="@"_+DGJU MP;"KRN",. 402,83,"DR ",2,2)S:+D GJUMP'=2 Y ="@991";S  DGJUMP=$P( DGJUMP,"2, ",2);.05;6 ETHNICITY~ ;2RACE~;57 .4;S:+DGJU MP'=3 Y="@ 991";@31;S  DGJUMP=$P (DGJUMP,"3 ,",2);.321 01;.32102; S:X'="Y" Y =.32103;.3 213;.32103 ;S:X'="Y"  Y="@32";.3 212;@32;.5 25;S:X'="Y " Y="@42"; .526;"KRN" ,.402,83," DR",2,2,1) @42;S:+DGJ UMP'=4 Y=" @991";@41; S DGJUMP=$ P(DGJUMP," 4,",2);@99 1;I +DGJUM P>2&(+DGJU MP<5) S Y= "@"_+DGJUM P_1;"KRN", .402,83,"D R",2,405)D  PTF101^DG PTFCLV;"KR N",.402,83 ,"DR",3,2. 02).01RACE ~;I $P($G( ^DIC(10.3, +$P($G(^DP T(DA(1),.0 2,DA,0))," ^",2),0)), "^",2)="S"  S Y="@21" ;.02;@21;" KRN",.402, 83,"DR",3, 2.06).01ET HNICITY~;I  $P($G(^DI C(10.3,+$P ($G(^DPT(D A(1),.06,D A,0)),"^", 2),0)),"^" ,2)="S" S  Y="@61";.0 2;@61;"KRN ",.402,83, "DR",99,1) S I(0,0)=$ G(D0),D0=$ O(^DGPM("A PTF",I(0,0 ),0)) S:$O (^(D0))>0  D0=0 S X=$ S(D0>0:D0, 1:""),D(0) =X S D0=I( 0,0)"KRN", .402,83,"D R",99,1,9. 2)N DIADD, DIC S DIC= 405,DIC(0) ="",DIC("S ")="I $D(^ DGPM(""APT F"","_I(0, 0)_",Y))"  D ^DIC S D 0=+Y,DIC(. 16)=I(0,0) ,DIH=405 D  DICL^DICR :$P(Y,U,3) "KRN",.402 ,83,"ROU") ^DGPTX1"KR N",.402,83 ,"ROUOLD") DGPTX1"KRN ",.402,84, -1)0^2"KRN ",.402,84, 0)DG101F^3 171226.110 4^^45^^^31 80123"KRN" ,.402,84," DIAB",1,2, 2.02,0).01 ;"RACE""KR N",.402,84 ,"DIAB",1, 2,2.06,0). 01;"ETHNIC ITY""KRN", .402,84,"D IAB",2,0,4 5,1)PATIEN T:"KRN",.4 02,84,"DIA B",4,1,2,0 )6;"ETHNIC ITY""KRN", .402,84,"D IAB",5,1,2 ,0)2;"RACE ""KRN",.40 2,84,"DIAB ",6,0,45,0 )20;REQ"KR N",.402,84 ,"DR",1,45 )S:+DGJUMP '=1 Y="@99 ";@1;S DGJ UMP=$P(DGJ UMP,"1,",2 );3//^S X= $P($$SITE^ VASITE,U,3 );5;20R~;2 2;21.1;21. 2;20.1//// ^S X=$$ELI G^DGUTL3(D FN,1,$P($G (^DGPT(DA, 101)),U,8) );I DGPTFM T>1 S Y="@ 10";23;@10 ;S:+DGJUMP '=2 Y="@99 ";@2;@3;@4 ;"KRN",.40 2,84,"DR", 1,45,1)S D GCLV=DGJUM P;^2^DPT(^ ^S I(0,0)= D0 S Y(1)= $S($D(^DGP T(D0,0)):^ (0),1:"")  S X=$P(Y(1 ),U,1),X=X   S D(0)=+ X S X=$S(D (0)>0:D(0) ,1:"");S:( +$G(DGCLV) =2)!(+$G(D GCLV)=4) Y ="@99";S:$ $GETCL^DGU TL3(DFN)'= 1 Y="@37"; D PTF101F^ DGPTFCLV;@ 37;"KRN",. 402,84,"DR ",1,45,2)S :+DGJUMP'= 5 Y="@99"; @5;S DGJUM P=$P(DGJUM P,"5,",2); 70;71;72;7 2.1;75;10; S:+DGJUMP' =6 Y="@99" ;@6;S DGJU MP=$P(DGJU MP,"6,",2) ;73;74;S:D GJUMP'=7 Y ="@99";@7; S DGJUMP=$ P(DGJUMP," 7,",2);76. 1;76.2;78; 77;@99;S:+ DGJUMP Y=" @"_+DGJUMP ;"KRN",.40 2,84,"DR", 2,2)S:+DGJ UMP'=2 Y=" @991";S DG JUMP=$P(DG JUMP,"2,", 2);.05;6ET HNICITY~;2 RACE~;57.4 ;S:+DGJUMP '=3 Y="@99 1";@31;S D GJUMP=$P(D GJUMP,"3," ,2);.32101 ;.32102;S: X'="Y" Y=. 32103;.321 3;.32103;S :X'="Y" Y= "@32";.321 2;@32;.525 ;S:X'="Y"  Y="@42";.5 26;"KRN",. 402,84,"DR ",2,2,1)@4 2;S:+DGJUM P'=4 Y="@9 91";@41;S  DGJUMP=$P( DGJUMP,"4, ",2);@991; I +DGJUMP> 2&(+DGJUMP <5) S Y="@ "_+DGJUMP_ 1;"KRN",.4 02,84,"DR" ,3,2.02).0 1RACE~;I $ P($G(^DIC( 10.3,+$P($ G(^DPT(DA( 1),.02,DA, 0)),"^",2) ,0)),"^",2 )="S" S Y= "@21";.02; @21;"KRN", .402,84,"D R",3,2.06) .01ETHNICI TY~;I $P($ G(^DIC(10. 3,+$P($G(^ DPT(DA(1), .06,DA,0)) ,"^",2),0) ),"^",2)=" S" S Y="@6 1";.02;@61 ;"KRN",.40 2,87,-1)0^ 5"KRN",.40 2,87,0)DG5 01F^318011 2.0954^^45 ^^^3130328 "KRN",.402 ,87,"AR",4 5.02,1173) 1^DGX5F4"K RN",.402,8 7,"AR",45. 02,1174)2^ DGX5F4"KRN ",.402,87, "AR",45.02 ,1175)3^DG X5F4"KRN", .402,87,"A R",45.02,1 176)4^DGX5 F4"KRN",.4 02,87,"AR" ,45.02,117 7)5^DGX5F4 "KRN",.402 ,87,"AR",4 5.02,1178) 6^DGX5F4"K RN",.402,8 7,"AR",45. 02,1179)7^ DGX5F4"KRN ",.402,87, "AR",45.02 ,1180)8^DG X5F4"KRN", .402,87,"A R",45.02,1 181)9^DGX5 F4"KRN",.4 02,87,"AR" ,45.02,118 2)10^DGX5F 4"KRN",.40 2,87,"AR", 45.02,1221 )11^DGX5F4 "KRN",.402 ,87,"AR",4 5.02,1222) 12^DGX5F4" KRN",.402, 87,"AR",45 .02,1223)1 3^DGX5F4"K RN",.402,8 7,"AR",45. 02,1224)14 ^DGX5F4"KR N",.402,87 ,"AR",45.0 2,1225)15^ DGX5F4"KRN ",.402,87, "AR",45.02 ,1226)16^D GX5F4"KRN" ,.402,87," AR",45.02, 1227)17^DG X5F4"KRN", .402,87,"A R",45.02,1 228)18^DGX 5F4"KRN",. 402,87,"AR ",45.02,12 29)19^DGX5 F4"KRN",.4 02,87,"AR" ,45.02,123 0)20^DGX5F 4"KRN",.40 2,87,"AR", 45.02,1231 )21^DGX5F4 "KRN",.402 ,87,"AR",4 5.02,1232) 22^DGX5F4" KRN",.402, 87,"AR",45 .02,1233)2 3^DGX5F4"K RN",.402,8 7,"AR",45. 02,1234)24 ^DGX5F4"KR N",.402,87 ,"AR",45.0 2,1235)25^ DGX5F4"KRN ",.402,87, "DIAB",1,1 ,45.02,1)T REATED FOR  SC CONDIT ION//NO;"W AS TREATME NT FOR A S ERVICE CON NECTED CON DITION?""K RN",.402,8 7,"DIAB",1 ,1,45.02,1 0)TREATED  FOR AO CON DITION;"WA S TREATMEN T RELATED  TO AGENT O RANGE EXPO SURE?""KRN ",.402,87, "DIAB",1,1 ,45.02,11) EXPOSED TO  SW ASIA C ONDITIONS; "WAS TREAT MENT RELAT ED TO SERV ICE IN SW  ASIA?""KRN ",.402,87, "DIAB",1,1 ,45.02,12) 29;"WAS TR EATMENT RE LATED TO M ILITARY SE XUAL TRAUM A?""KRN",. 402,87,"DI AB",5,1,45 .02,9)POTE NTIALLY RE LATED TO C OMBAT//YES ;"WAS TREA TMENT RELA TED TO COM BAT?""KRN" ,.402,87," DIAB",5,1, 45.02,13)3 3//"NO";"W AS TREATME NT RELATED  TO CAMP L EJEUNE?""K RN",.402,8 7,"DIAB",7 ,1,45.02,1 0)TREATED  FOR IR CON DITION;"WA S TREATMEN T RELATED  TO IONIZIN G RADIATIO N EXPOSURE ?""KRN",.4 02,87,"DIA B",7,1,45. 02,11)32;" WAS TREATM ENT RELATE D TO PROJ  112/SHAD?" "KRN",.402 ,87,"DIAB" ,7,1,45.02 ,12)30;"WA S TREATMEN T RELATED  TO HEAD AN D/OR NECK  CANCER?""K RN",.402,8 7,"DR",1,4 5)F X=2:1: 7 S DGDUP( X)=0;K DGP TIT;I $G(D GPTF)<1 S  DGPTF=D0 W  !!,"Editi ng PTF Rec ord "_DGPT F_" in VA  FileManage r.";I $G(D GMOV)<1 S  DGMOV=1 W  !!,"Editin g Discharg e Movement  in VA Fil eManager"; I $G(DFN)< 1 S DFN=+$ G(^DGPT(D0 ,0));"KRN" ,.402,87," DR",1,45,1 )D CENSUS^ DGPTIC10(D A);S DGJUM P=$G(DGJUM P);S DGXX= "",DGTYPE= $P(^DGPT(D 0,0),U,11) ,DGCODSYS= $$CODESYS^ DGPTIC10(D 0);S DGHOL D=$S($D(^D GPT(DGPTF, "M",+DGMOV ,0)):^(0), 1:"");S:'$ D(DGADD) D GADD=0;S D GNFLD="@10 ";50///^S  X=+DGMOV;" KRN",.402, 87,"DR",2, 45.02)S:DG JUMP'[1 Y= "@2";10;@1 0;S DGNFLD ="@15";2;@ 15;S DGNFL D="@16";3; @16;S DGNF LD="@17";4 ;@17;S:DGJ UMP'[2 Y=0 ;@2;I $D(^ DPT(+^DGPT (DGPTF,0), .3)),$P(^( .3),U)="Y"  S (DGNFLD ,Y)="@25"; 18////^S X =2;S (DGNF LD,Y)="@27 ";@25;"KRN ",.402,87, "DR",2,45. 02,1)18WAS  TREATMENT  FOR A SER VICE CONNE CTED CONDI TION?~//NO ;@27;S DGN FLD="@28"; S Y="@9000 ";@28;S DG NFLD="@40" ;5;S DGXX= X;I DGCODS YS="ICD9"! (DGTYPE=2) !(DGXX="")  S Y="@26" ;82.01;@26 ;S X=DGXX; "KRN",.402 ,87,"DR",2 ,45.02,2)I  X K DGPTI T S DGNFLD ="@40",Y=" @8000",DGP TIT(X_$C(5 9)_"ICD9(" )="";@40;I  DGADD,$P( DGHOLD,U,6 )]"" S Y=" @50";S DGN FLD="@50"; 6;S DGXX=X ;I DGCODSY S="ICD9"!( DGTYPE=2)! (DGXX="")  S Y="@41"; 82.02;@41; S X=DGXX;" KRN",.402, 87,"DR",2, 45.02,3)I  X K DGPTIT  S DGNFLD= "@50",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@50;I  DGADD,$P(D GHOLD,U,7) ]"" S Y="@ 60";S DGNF LD="@60";7 ;S DGXX=X; I DGCODSYS ="ICD9"!(D GTYPE=2)!( DGXX="") S  Y="@51";8 2.03;@51;S  X=DGXX;"K RN",.402,8 7,"DR",2,4 5.02,4)I X  K DGPTIT  S DGNFLD=" @60",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@60;I D GADD,$P(DG HOLD,U,8)] "" S Y="@7 0";S DGNFL D="@70";8; S DGXX=X;I  DGCODSYS= "ICD9"!(DG TYPE=2)!(D GXX="") S  Y="@61";82 .04;@61;S  X=DGXX;"KR N",.402,87 ,"DR",2,45 .02,5)I X  K DGPTIT S  DGNFLD="@ 70",Y="@80 00",DGPTIT (X_$C(59)_ "ICD9(")=" ";@70;I DG ADD,$P(DGH OLD,U,9)]" " S Y="@80 ";S DGNFLD ="@80";9;S  DGXX=X;I  DGCODSYS=" ICD9"!(DGT YPE=2)!(DG XX="") S Y ="@71";82. 05;@71;S X =DGXX;"KRN ",.402,87, "DR",2,45. 02,6)I X K  DGPTIT S  DGNFLD="@8 0",Y="@800 0",DGPTIT( X_$C(59)_" ICD9(")="" ;@80;K DGN FLD,DGDUP, DGADD,DGXX ,DGCODSYS  S Y="";@80 00;D SCAN^ DGPTSCAN S :'$D(DGBPC ) Y="@8990 ";I '$D(DG BPC(2))!(D GDUP(2)) S  Y="@8200" ;300.02;S: X]"" DGDUP (2)=1;@820 0;"KRN",.4 02,87,"DR" ,2,45.02,7 )I '$D(DGB PC(3))!(DG DUP(3)) S  Y="@8300"; 300.03;S:X ]"" DGDUP( 3)=1;@8300 ;I '$D(DGB PC(4))!(DG DUP(4)) S  Y="@8400"; D DRUG^DGP TSC01 I $D (DGTX) S Y ="@8350";3 00.04;S:X] "" DGDUP(4 )=1;S Y="@ 8400";@835 0;300.04// ^S X=DGTX; S:X]"" DGD UP(4)=1;"K RN",.402,8 7,"DR",2,4 5.02,8)@84 00;I '$D(D GBPC(5))!( DGDUP(5))  S Y="@8500 ";300.05;S :X]"" DGDU P(5)=1;@85 00;I '$D(D GBPC(6))!( DGDUP(6))  S Y="@8600 ";300.06;S :X]"" DGDU P(6)=1;@86 00;I '$D(D GBPC(7))!( DGDUP(7))  S Y="@8990 ";300.07;S :X]"" DGDU P(7)=1;@89 90;"KRN",. 402,87,"DR ",2,45.02, 9)K DGPTIT  S Y=DGNFL D;@9000;K  DGEXQ D CH QUES^DGPTS PQ I '$D(D GEXQ) S Y= "@9999";I  '$D(DGEXQ( 6)) S Y="@ 9040";31WA S TREATMEN T RELATED  TO COMBAT? ~//YES;S Y ="@9050";@ 9040;31/// @;@9050;I  '$D(DGEXQ( 1)) S Y="@ 9100";"KRN ",.402,87, "DR",2,45. 02,10)26WA S TREATMEN T RELATED  TO AGENT O RANGE EXPO SURE?~;S Y ="@9150";@ 9100;26/// @;@9150;I  '$D(DGEXQ( 2)) S Y="@ 9200";27WA S TREATMEN T RELATED  TO IONIZIN G RADIATIO N EXPOSURE ?~;S Y="@9 250";@9200 ;27///@;@9 250;I '$D( DGEXQ(3))  S Y="@9300 ";"KRN",.4 02,87,"DR" ,2,45.02,1 1)28WAS TR EATMENT RE LATED TO S ERVICE IN  SW ASIA?~; S Y="@9350 ";@9300;28 ///@;@9350 ;I '$D(DGE XQ(7)) S Y ="@9400";3 2WAS TREAT MENT RELAT ED TO PROJ  112/SHAD? ~;S Y="@94 50";@9400; 32///@;@94 50;I '$D(D GEXQ(4)) S  Y="@9500" ;"KRN",.40 2,87,"DR", 2,45.02,12 )29WAS TRE ATMENT REL ATED TO MI LITARY SEX UAL TRAUMA ?~;S Y="@9 550";@9500 ;29///@;@9 550;I '$D( DGEXQ(5))  S Y="@9600 ";30WAS TR EATMENT RE LATED TO H EAD AND/OR  NECK CANC ER?~;I X[" Y",$D(DFN) ,$$FILEHNC ^DGNTAPI1( DFN);S Y=" @9650";@96 00;30///@; "KRN",.402 ,87,"DR",2 ,45.02,13) @9650;I '$ D(DGEXQ(8) ) S Y="@97 00";S:$$GE TCL^DGUTL3 (DFN)'=1 Y ="@9700";Q ;33WAS TRE ATMENT REL ATED TO CA MP LEJEUNE ?~//^S X=" NO";S Y="@ 9750";@970 0;33///@;@ 9750;@9999 ;K DGEXQ S  Y=DGNFLD; @99999;"KR N",.402,87 ,"ROU")^DG X5F"KRN",. 402,87,"RO UOLD")DGX5 F"KRN",.40 2,88,-1)0^ 4"KRN",.40 2,88,0)DG5 01^3180112 .0952^^45^ ^^3171207" KRN",.402, 88,"AR",45 .02,1173)1 ^DGPTX54"K RN",.402,8 8,"AR",45. 02,1175)2^ DGPTX54"KR N",.402,88 ,"AR",45.0 2,1176)3^D GPTX54"KRN ",.402,88, "AR",45.02 ,1177)4^DG PTX54"KRN" ,.402,88," AR",45.02, 1178)5^DGP TX54"KRN", .402,88,"D IAB",1,1,4 5.02,1)18; "WAS TREAT MENT FOR A  SERVICE C ONNECTED C ONDITION?" //NO"KRN", .402,88,"D IAB",1,1,4 5.02,10)26 ;"WAS TREA TMENT RELA TED TO AGE NT ORANGE  EXPOSURE?" "KRN",.402 ,88,"DIAB" ,1,1,45.02 ,11)28;"WA S TREATMEN T RELATED  TO SERVICE  IN SW ASI A?""KRN",. 402,88,"DI AB",1,1,45 .02,12)29; "WAS TREAT MENT RELAT ED TO MILI TARY SEXUA L TRAUMA?" "KRN",.402 ,88,"DIAB" ,1,1,45.02 ,14)PATIEN T MOVEMENT :"KRN",.40 2,88,"DIAB ",2,1,45.0 2,14)33//^ S X=DGX;"W AS TREATME NT RELATED  TO CAMP L EJEUNE?""K RN",.402,8 8,"DIAB",5 ,1,45.02,9 )31;"WAS T REATMENT R ELATED TO  COMBAT?"// /YES"KRN", .402,88,"D IAB",7,1,4 5.02,10)27 ;"WAS TREA TMENT RELA TED TO ION IZING RADI ATION EXPO SURE?""KRN ",.402,88, "DIAB",7,1 ,45.02,11) 32;"WAS TR EATMENT RE LATED TO P ROJ 112/SH AD?""KRN", .402,88,"D IAB",7,1,4 5.02,12)30 ;"WAS TREA TMENT RELA TED TO HEA D AND/OR N ECK CANCER ?""KRN",.4 02,88,"DR" ,1,45)F X= 2:1:7 S DG DUP(X)=0;K  DGPTIT;I  $G(DGPTF)< 1 S DGPTF= D0 W !!,"E diting PTF  Record "_ DGPTF_" in  VA FileMa nager.";I  $G(DGMOV)< 1 S DGMOV= 1 W !!,"Ed iting Disc harge Move ment in VA  FileManag er";I $G(D FN)<1 S DF N=+$G(^DGP T(D0,0));" KRN",.402, 88,"DR",1, 45,1)D CEN SUS^DGPTIC 10(DA);S D GJUMP=$G(D GJUMP);S D GXX="",DGT YPE=$P(^DG PT(D0,0),U ,11),DGCOD SYS=$$CODE SYS^DGPTIC 10(D0);S D GHOLD=$S($ D(^DGPT(DG PTF,"M",+D GMOV,0)):^ (0),1:""); 50///^S X= +DGMOV;"KR N",.402,88 ,"DR",2,45 .02)S:'$D( DGADD) DGA DD=0;S:DGJ UMP'[1 Y=" @2";S:DGAD D Y="@20"; S DGNFLD=" @10";3;@10 ;S DGNFLD= "@15";4;I  $D(^DPT(+^ DGPT(DGPTF ,0),.3)),$ P(^(.3),U) ="Y" S Y=" @15";18/// /^S X=2;S  (DGNFLD,Y) ="@20";@15 ;"KRN",.40 2,88,"DR", 2,45.02,1) 18WAS TREA TMENT FOR  A SERVICE  CONNECTED  CONDITION? ~;@20;S:DG JUMP'[2 Y= "";@2;S DG NFLD="@25" ;S Y="@900 0";@25;I D GADD,$P(DG HOLD,U,5)] "" S Y="@4 0";S DGNFL D="@40";5; S DGXX=X;I  DGCODSYS= "ICD9"!(DG TYPE=2)!(D GXX="") S  Y="@26";82 .01;@26;"K RN",.402,8 8,"DR",2,4 5.02,2)S X =DGXX;I X  K DGPTIT S  DGNFLD="@ 40",Y="@80 00",DGPTIT (X_$C(59)_ "ICD9(")=" ";@40;I DG ADD,$P(DGH OLD,U,6)]" " S Y="@50 ";S DGNFLD ="@50";6;S  DGXX=X;I  DGCODSYS=" ICD9"!(DGT YPE=2)!(DG XX="") S Y ="@41";82. 02;@41;S X =DGXX;"KRN ",.402,88, "DR",2,45. 02,3)I X K  DGPTIT S  DGNFLD="@5 0",Y="@800 0",DGPTIT( X_$C(59)_" ICD9(")="" ;@50;I DGA DD,$P(DGHO LD,U,7)]""  S Y="@60" ;S DGNFLD= "@60";7;S  DGXX=X;I D GCODSYS="I CD9"!(DGTY PE=2)!(DGX X="") S Y= "@51";82.0 3;@51;S X= DGXX;"KRN" ,.402,88," DR",2,45.0 2,4)I X K  DGPTIT S D GNFLD="@60 ",Y="@8000 ",DGPTIT(X _$C(59)_"I CD9(")=""; @60;I DGAD D,$P(DGHOL D,U,8)]""  S Y="@70"; S DGNFLD=" @70";8;S D GXX=X;I DG CODSYS="IC D9"!(DGTYP E=2)!(DGXX ="") S Y=" @61";82.04 ;@61;S X=D GXX;"KRN", .402,88,"D R",2,45.02 ,5)I X K D GPTIT S DG NFLD="@70" ,Y="@8000" ,DGPTIT(X_ $C(59)_"IC D9(")="";@ 70;I DGADD ,$P(DGHOLD ,U,9)]"" S  Y="@80";S  DGNFLD="@ 80";9;S DG XX=X;I DGC ODSYS="ICD 9"!(DGTYPE =2)!(DGXX= "") S Y="@ 71";82.05; @71;S X=DG XX;"KRN",. 402,88,"DR ",2,45.02, 6)I X K DG PTIT S DGN FLD="@80", Y="@8000", DGPTIT(X_$ C(59)_"ICD 9(")="";@8 0;K DGNFLD ,DGDUP,DGA DD S Y=""; @8000;D SC AN^DGPTSCA N S:'$D(DG BPC) Y="@8 990";I '$D (DGBPC(2)) !(DGDUP(2) ) S Y="@81 00";300.02 ;S:X]"" DG DUP(2)=1;@ 8100;"KRN" ,.402,88," DR",2,45.0 2,7)I '$D( DGBPC(3))! (DGDUP(3))  S Y="@820 0";300.03; S:X]"" DGD UP(3)=1;@8 200;I '$D( DGBPC(4))! (DGDUP(4))  S Y="@830 0";D DRUG^ DGPTSC01 I  $D(DGTX)  S Y="@8250 ";300.04;S :X]"" DGDU P(4)=1;S Y ="@8300";@ 8250;300.0 4//^S X=DG TX;S:X]""  DGDUP(4)=1 ;"KRN",.40 2,88,"DR", 2,45.02,8) @8300;I '$ D(DGBPC(5) )!(DGDUP(5 )) S Y="@8 400";300.0 5;S:X]"" D GDUP(5)=1; @8400;I '$ D(DGBPC(6) )!(DGDUP(6 )) S Y="@8 500";300.0 6;S:X]"" D GDUP(6)=1; @8500;I '$ D(DGBPC(7) )!(DGDUP(7 )) S Y="@8 990";300.0 7;S:X]"" D GDUP(7)=1; @8990;"KRN ",.402,88, "DR",2,45. 02,9)K DGP TIT,DGTX S  Y=DGNFLD; @9000;K DG EXQ D CHQU ES^DGPTSPQ  I '$D(DGE XQ) S Y="@ 9999";I '$ D(DGEXQ(6) ) S Y="@90 40";31WAS  TREATMENT  RELATED TO  COMBAT?~; S Y="@9050 ";@9040;31 ///@;@9050 ;I '$D(DGE XQ(1)) S Y ="@9100";" KRN",.402, 88,"DR",2, 45.02,10)2 6WAS TREAT MENT RELAT ED TO AGEN T ORANGE E XPOSURE?~; S Y="@9150 ";@9100;26 ///@;@9150 ;I '$D(DGE XQ(2)) S Y ="@9200";2 7WAS TREAT MENT RELAT ED TO IONI ZING RADIA TION EXPOS URE?~;S Y= "@9250";@9 200;27///@ ;@9250;I ' $D(DGEXQ(3 )) S Y="@9 300";"KRN" ,.402,88," DR",2,45.0 2,11)28WAS  TREATMENT  RELATED T O SERVICE  IN SW ASIA ?~;S Y="@9 350";@9300 ;28///@;@9 350;I '$D( DGEXQ(7))  S Y="@9400 ";32WAS TR EATMENT RE LATED TO P ROJ 112/SH AD?~;S Y=" @9450";@94 00;32///@; @9450;I '$ D(DGEXQ(4) ) S Y="@95 00";"KRN", .402,88,"D R",2,45.02 ,12)29WAS  TREATMENT  RELATED TO  MILITARY  SEXUAL TRA UMA?~;S Y= "@9550";@9 500;29///@ ;@9550;I ' $D(DGEXQ(5 )) S Y="@9 600";30WAS  TREATMENT  RELATED T O HEAD AND /OR NECK C ANCER?~;I  X["Y",$D(D FN),$$FILE HNC^DGNTAP I1(DFN);S  Y="@9650"; @9600;30// /@;"KRN",. 402,88,"DR ",2,45.02, 13)@9650;I  '$D(DGEXQ (8)) S Y=" @9700";S:$ $GETCL^DGU TL3(DFN)'= 1 Y="@9700 ";"KRN",.4 02,88,"DR" ,2,45.02,1 4)^405^DGP M(^^S I(1, 0)=$G(D1), I(0,0)=$G( D0),D0=$O( ^DGPM("APT F",I(0,0), 0)) S:$O(^ (D0))>0 D0 =0 S X=$S( D0>0:D0,1: ""),D(0)=X  S D0=I(0, 0) S D1=I( 1,0) S X=$ S(D(0)>0:D (0),1:""); 33WAS TREA TMENT RELA TED TO CAM P LEJEUNE? ~//^S X=DG X;@9700;"K RN",.402,8 8,"DR",2,4 5.02,15)33 ///@;@9750 ;@9999;K D GEXQ S Y=D GNFLD;"KRN ",.402,88, "DR",3,405 )K DGX S D GX=$P(^DGP T(DGPTF,"M ",+$G(DGMO V),0),U,33 );I $G(DGX )'="" S X= $S($G(DGX) ="Y":"YES" ,1:"NO"),Y ="@28";S D GX=$S($P(^ DGPM(DA,"C LV"),U,1)= "Y":"YES", 1:"NO");@2 8;"KRN",.4 02,88,"DR" ,99,1)S I( 1,0)=$G(D1 ),I(0,0)=$ G(D0),D0=$ O(^DGPM("A PTF",I(0,0 ),0)) S:$O (^(D0))>0  D0=0 S X=$ S(D0>0:D0, 1:""),D(0) =X S D0=I( 0,0) S D1= I(1,0)"KRN ",.402,88, "DR",99,1, 9.2)N DIAD D,DIC S DI C=405,DIC( 0)="",DIC( "S")="I $D (^DGPM(""A PTF"","_I( 0,0)_",Y)) " D ^DIC S  D0=+Y,DIC (.16)=I(0, 0),DIH=405  D DICL^DI CR:$P(Y,U, 3)"KRN",.4 02,88,"ROU ")^DGPTX5" KRN",.402, 88,"ROUOLD ")DGPTX5"K RN",.402,5 39,-1)0^7" KRN",.402, 539,0)DGQW K^3180105. 1128^^45^^ ^3180112"K RN",.402,5 39,"DIAB", 1,2,2.02,0 ).01;"RACE ""KRN",.40 2,539,"DIA B",1,2,2.0 6,0).01;"E THNICITY"" KRN",.402, 539,"DIAB" ,2,1,2,0)6 ;"ETHNICIT Y""KRN",.4 02,539,"DI AB",3,1,2, 0)2;"RACE" "KRN",.402 ,539,"DIAB ",8,0,45,0 )PATIENT:" KRN",.402, 539,"DR",1 ,45)3//^S  X=$P($$SIT E^VASITE,U ,3);5;20;2 2;21.1;21. 2;20.1//// ^S X=$$ELI G^DGUTL3(D FN,2,$P($G (^DGPT(DA, 101)),U,8) );^2^DPT(^ ^S I(0,0)= D0 S Y(1)= $S($D(^DGP T(D0,0)):^ (0),1:"")  S X=$P(Y(1 ),U,1),X=X   S D(0)=+ X S X=$S(D (0)>0:D(0) ,1:"");"KR N",.402,53 9,"DR",1,4 5,1)S:$$GE TCL^DGUTL3 (DFN)'=1 Y ="@27";D P TF101^DGPT FCLV;@27;7 5;73;74;76 .1;76.2;78 ;77;"KRN", .402,539," DR",2,2).0 5;6ETHNICI TY~;2RACE~ ;57.4;.321 01;.32102; S:X'="Y" Y =.32103;.3 213;.32103 ;S:X'="Y"  Y="@22";.3 212;@22;.5 25;S:X'="Y " Y=.115;. 526;"KRN", .402,539," DR",3,2.02 ).01RACE~; I $P($G(^D IC(10.3,+$ P($G(^DPT( DA(1),.02, DA,0)),"^" ,2),0)),"^ ",2)="S" S  Y="@21";. 02;@21;"KR N",.402,53 9,"DR",3,2 .06).01ETH NICITY~;I  $P($G(^DIC (10.3,+$P( $G(^DPT(DA (1),.06,DA ,0)),"^",2 ),0)),"^", 2)="S" S Y ="@61";.02 ;@61;"KRN" ,.402,540, -1)0^8"KRN ",.402,540 ,0)DGQWKF^ 3180108.08 01^^45^^^3 180112"KRN ",.402,540 ,"DIAB",1, 2,2.02,0). 01;"RACE"" KRN",.402, 540,"DIAB" ,1,2,2.06, 0).01;"ETH NICITY""KR N",.402,54 0,"DIAB",2 ,1,2,0)6;" ETHNICITY" "KRN",.402 ,540,"DIAB ",3,1,2,0) 2;"RACE""K RN",.402,5 40,"DIAB", 8,0,45,0)P ATIENT:"KR N",.402,54 0,"DR",1,4 5)3//^S X= $P($$SITE^ VASITE,U,3 );5;20;22; 21.1;21.2; 20.1////^S  X=$$ELIG^ DGUTL3(DFN ,2,$P($G(^ DGPT(DA,10 1)),U,8)); ^2^DPT(^^S  I(0,0)=D0  S Y(1)=$S ($D(^DGPT( D0,0)):^(0 ),1:"") S  X=$P(Y(1), U,1),X=X   S D(0)=+X  S X=$S(D(0 )>0:D(0),1 :"");"KRN" ,.402,540, "DR",1,45, 1)S:$$GETC L^DGUTL3(D FN)'=1 Y=" @37";D PTF 101F^DGPTF CLV;@37;10 ;70;71;72; 72.1;75;73 ;74;76.1;7 6.2;78;77; "KRN",.402 ,540,"DR", 2,2).05;6E THNICITY~; 2RACE~;57. 4;.32101;. 32102;S:X' ="Y" Y=.32 103;.3213; .32103;S:X '="Y" Y="@ 22";.3212; @22;.525;@ 27;S:X'="Y " Y=.115;. 526;"KRN", .402,540," DR",3,2.02 ).01RACE~; I $P($G(^D IC(10.3,+$ P($G(^DPT( DA(1),.02, DA,0)),"^" ,2),0)),"^ ",2)="S" S  Y="@21";. 02;@21;"KR N",.402,54 0,"DR",3,2 .06).01ETH NICITY~;I  $P($G(^DIC (10.3,+$P( $G(^DPT(DA (1),.06,DA ,0)),"^",2 ),0)),"^", 2)="S" S Y ="@61";.02 ;@61;"KRN" ,.402,1098 ,-1)0^11"K RN",.402,1 098,0)DGPM  ADMIT^317 1213.155^^ 405^^^3180 112"KRN",. 402,1098," %D",0)^^3^ 3^3171206^ ^"KRN",.40 2,1098,"%D ",1,0)This  template  is used by  routine D GPMV3 to c apture adm ission dat a for a"KR N",.402,10 98,"%D",2, 0)particul ar patient . This tem plate cann ot be used  without t he interac tion"KRN", .402,1098, "%D",3,0)o f the 'Adm it a Patie nt' option  in MAS."K RN",.402,1 098,"DIAB" ,2,0,405,2 ).04;"TYPE  OF ADMISS ION""KRN", .402,1098, "DIAB",3,0 ,405,0)41; "DOES THE  PATIENT WI SH TO BE E XCLUDED FR OM THE FAC ILITY DIRE CTORY?";RE Q"KRN",.40 2,1098,"DI AB",6,0,40 5,1)TREATM ENT FOR CA MP LEJEUNE //"NO";"WA S TREATMEN T RELATED  TO CAMP LE JEUNE?""KR N",.402,10 98,"DIAB", 7,0,405,3) 103///NOW" KRN",.402, 1098,"DR", 1,405)S:$S (DGPMN:1,D GPMY=+^DGP M(DA,0):1, 1:0) Y=41; .01///^S X =DGPMY;41R ~DOES THE  PATIENT WI SH TO BE E XCLUDED FR OM THE FAC ILITY DIRE CTORY?~;.1 2;54////^S  X=$$ADCAT ^DGSAUTL($ P(^DGPM(DA ,0),U,12)) ;"KRN",.40 2,1098,"DR ",1,405,1) I $S('$D(^ DPT(DFN,.3 )):1,$P(^( .3),"^",1) '="Y":1,1: 0) S Y="@1 1";.11;@11 ;I $P($G(^ DPT(DFN,.3 217)),U,1) '="Y" S Y= "@12";Q;29 WAS TREATM ENT RELATE D TO CAMP  LEJEUNE?~/ /^S X="NO" ;@12;"KRN" ,.402,1098 ,"DR",1,40 5,2)S ^DIS V(DUZ,"^DG (405.1,")= $S($D(^DIS V(DUZ,"DGP M1")):^("D GPM1"),1:" ");.04TYPE  OF ADMISS ION~;S ^DI SV(DUZ,"DG PM1")=$S($ D(^DISV(DU Z,"^DG(405 .1,")):^(" ^DG(405.1, "),1:"");I  $P(^DGPM( DA,0),"^", 18)'=9 S Y =.1;.05;.1 ;.06;.07;" KRN",.402, 1098,"DR", 1,405,3)D  DFN^DGYZOD S S:'DGODS  Y="@13";1 1500.01/// /1;@13;I D GPMP=^DGPM (DA,0) S Y ="";102/// /^S X=DUZ; Q;103///^N  %I,%H,% D  NOW^%DTC  S X=%;"KRN ",.402,109 8,"ROU")^D GPMX1"KRN" ,.402,1098 ,"ROUOLD") DGPMX1"KRN ",.402,110 3,-1)0^12" KRN",.402, 1103,0)DGP M SPECIALT Y TRANSFER ^3171206.1 229^^405^^ ^3180116"K RN",.402,1 103,"DIAB" ,1,0,405,3 )103///NOW "KRN",.402 ,1103,"DIA B",2,0,405 ,1).04;"SP ECIALTY TR ANSFER TYP E""KRN",.4 02,1103,"D IAB",4,0,4 05,2)29//" NO";"WAS T REATMENT R ELATED TO  CAMP LEJEU NE?""KRN", .402,1103, "DR",1,405 )S:$S(DGPM N:1,DGPMY= +^DGPM(DA, 0):1,1:0)  Y="@10";.0 1///^S X=D GPMY;@10;S :$D(DGPMPC ) Y="@35"; D ONLY^DGP MV36 S:'$D (DGPMSPI)  Y="@20";.0 4////^S X= DGPMSPI;K  DGPMSPI;S  Y="@30";@2 0;"KRN",.4 02,1103,"D R",1,405,1 )S ^DISV(D UZ,"^DG(40 5.1,")=$S( $D(^DISV(D UZ,"DGPM6" )):^("DGPM 6"),1:""); .04SPECIAL TY TRANSFE R TYPE~;S  ^DISV(DUZ, "DGPM6")=$ S($D(^DISV (DUZ,"^DG( 405.1,")): ^("^DG(405 .1,"),1:"" );@30;.09; @35;.08;.1 9;"KRN",.4 02,1103,"D R",1,405,2 )I $P($G(^ DPT(DFN,.3 217)),U,1) '="Y" S Y= "@36";I $G (DGPMUC)=" ADMISSION"  S Y="@36" ;Q;29WAS T REATMENT R ELATED TO  CAMP LEJEU NE?~//^S X ="NO";@36; K DIE("NO^ ");S:$D(DG PMBYP) Y=" @40";99;@4 0;S:DGPMP= ^DGPM(DA,0 ) Y="";102 ////^S X=D UZ;Q;"KRN" ,.402,1103 ,"DR",1,40 5,3)103/// ^N %I,%H,%  D NOW^%DT C S X=%;"K RN",.402,1 103,"ROU") ^DGPMX6"KR N",.402,11 03,"ROUOLD ")DGPMX6"K RN",.402,1 104,-1)0^1 3"KRN",.40 2,1104,0)D GPM ASIH A DMIT^31712 06.1231^^4 05^^^31710 16"KRN",.4 02,1104,"% D",0)^.402 1^3^3^3000 425^^^^"KR N",.402,11 04,"%D",1, 0)This tem plate is u sed when t ransfering  a patient  TO ASIH o r CONTINUE D ASIH,"KR N",.402,11 04,"%D",2, 0)both of  which caus e a new ad mission to  be create d.  This t emplate ed its the"KR N",.402,11 04,"%D",3, 0)hospital  admission ."KRN",.40 2,1104,"DI AB",3,0,40 5,0)41;"DO ES THE PAT IENT WISH  TO BE EXCL UDED FROM  THE FACILI TY DIRECTO RY?";REQ"K RN",.402,1 104,"DIAB" ,4,0,405,1 )29//"NO"; "WAS TREAT MENT RELAT ED TO CAMP  LEJEUNE?" "KRN",.402 ,1104,"DIA B",11,0,40 5,1)103/// NOW"KRN",. 402,1104," DR",1,405) S:DGPMNA Y =41;.01/// ^S X=+DGPM A;41R~DOES  THE PATIE NT WISH TO  BE EXCLUD ED FROM TH E FACILITY  DIRECTORY ?~;.06//// ^S X=$P(DG PMA,"^",6) ;.07////^S  X=$P(DGPM A,"^",7);. 12;I $S('$ D(^DPT(DFN ,.3)):1,$P (^(.3),"^" ,1)'="Y":1 ,1:0) S Y= "@1";.11;" KRN",.402, 1104,"DR", 1,405,1)@1 ;I $P($G(^ DPT(DFN,.3 217)),U,1) '="Y" S Y= "@2";Q;29W AS TREATME NT RELATED  TO CAMP L EJEUNE?~// ^S X="NO"; @2;.1;D DF N^DGYZODS  S:'DGODS Y =102;11500 .01////1;1 02////^S X =DUZ;Q;103 ///^N %I,% H,% D NOW^ %DTC S X=% ;"KRN",.40 2,1104,"RO U")^DGPMXA "KRN",.402 ,1104,"ROU OLD")DGPMX A"KRN",.40 2,2138,-1) 0^6"KRN",. 402,2138,0 )DG801^317 1213.162^@ ^46.1^^@^3 180116"KRN ",.402,213 8,"DIAB",1 ,0,46.1,2) TREATED FO R AO CONDI TION;"WAS  TREATMENT  RELATED TO  AGENT ORA NGE EXPOSU RE?""KRN", .402,2138, "DIAB",1,0 ,46.1,5).0 6;"WAS TRE ATMENT REL ATED TO MI LITARY SEX UAL TRAUMA ?""KRN",.4 02,2138,"D IAB",2,0,4 6.1,1)COMB AT VET//YE S;"WAS TRE ATMENT REL ATED TO CO MBAT?""KRN ",.402,213 8,"DIAB",2 ,0,46.1,4) .09;"WAS T REATMENT R ELATED TO  PROJ 112/S HAD?""KRN" ,.402,2138 ,"DIAB",3, 0,46.1,0)T REATED FOR  SC CONDIT ION;"WAS T REATMENT F OR A SERVI CE CONNECT ED CONDITI ON?""KRN", .402,2138, "DIAB",4,0 ,46.1,3)EX POSURE TO  SW ASIA CO NDITIONS;" WAS TREATM ENT RELATE D TO SW AS IA CONDITI ONS?""KRN" ,.402,2138 ,"DIAB",5, 0,46.1,6)T REATMENT F OR CAMP LE JEUNE//"NO ";"WAS TRE ATMENT REL ATED TO CA MP LEJEUNE ?""KRN",.4 02,2138,"D IAB",7,0,4 6.1,2)TREA TMENT FOR  IR CONDITI ON;"WAS TR EATMENT RE LATED TO I ONIZING RA DIATION EX POSURE?""K RN",.402,2 138,"DIAB" ,7,0,46.1, 5).07;"WAS  TREATMENT  RELATED T O HEAD AND /OR NECK C ANCER?""KR N",.402,21 38,"DR",1, 46.1)I '$D (SDCLY(3))  S Y=$S($P ($G(^DGICD 9(46.1,D0, 0)),U,2)=" ":"@11",1: "@10");D E LIG^DGPTUT L1;.02WAS  TREATMENT  FOR A SERV ICE CONNEC TED CONDIT ION?~;S Y= "@11";@10; .02////0;@ 11;"KRN",. 402,2138," DR",1,46.1 ,1)I '$D(S DCLY(7)) S  Y=$S($P($ G(^DGICD9( 46.1,D0,0) ),U,8)="": "@21",1:"@ 20");.08WA S TREATMEN T RELATED  TO COMBAT? ~//YES;S Y ="@21";@20 ;.08////0; @21;I '$D( SDCLY(1))  S Y=$S($P( $G(^DGICD9 (46.1,D0,0 )),U,3)="" :"@31",1:" @30");"KRN ",.402,213 8,"DR",1,4 6.1,2).03W AS TREATME NT RELATED  TO AGENT  ORANGE EXP OSURE?~;S  Y="@31";@3 0;.03////0 ;@31;I '$D (SDCLY(2))  S Y=$S($P ($G(^DGICD 9(46.1,D0, 0)),U,4)=" ":"@41",1: "@40");.04 WAS TREATM ENT RELATE D TO IONIZ ING RADIAT ION EXPOSU RE?~;S Y=" @41";@40;" KRN",.402, 2138,"DR", 1,46.1,3). 04////0;@4 1;I '$D(SD CLY(4)) S  Y=$S($P($G (^DGICD9(4 6.1,D0,0)) ,U,5)="":" @51",1:"@5 0");.05WAS  TREATMENT  RELATED T O SW ASIA  CONDITIONS ?~;S Y="@5 1";@50;.05 ////0;@51; "KRN",.402 ,2138,"DR" ,1,46.1,4) I '$D(SDCL Y(8)) S Y= $S($P($G(^ DGICD9(46. 1,D0,0)),U ,9)="":"@6 1",1:"@60" );.09WAS T REATMENT R ELATED TO  PROJ 112/S HAD?~;S Y= "@61";@60; .09////0;@ 61;I '$D(S DCLY(5)) S  Y=$S($P($ G(^DGICD9( 46.1,D0,0) ),U,6)="": "@71",1:"@ 70");"KRN" ,.402,2138 ,"DR",1,46 .1,5).06WA S TREATMEN T RELATED  TO MILITAR Y SEXUAL T RAUMA?~;S  Y="@71";@7 0;.06////0 ;@71;I '$D (SDCLY(6))  S Y=$S($P ($G(^DGICD 9(46.1,D0, 0)),U,7)=" ":"@81",1: "@80");.07 WAS TREATM ENT RELATE D TO HEAD  AND/OR NEC K CANCER?~ ;S Y="@81" ;@80;.07// //0;"KRN", .402,2138, "DR",1,46. 1,6)@81;I  '$D(SDCLY( 9)) S Y="@ 90";S:$$GE TCL^DGUTL3 (DFN)'=1 Y ="@90";Q;. 1WAS TREAT MENT RELAT ED TO CAMP  LEJEUNE?~ //^S X="NO ";S Y="@91 ";@90;.1// //0;@91;@9 9;1////^S  X=PTF;"KRN ",.402,213 8,"ROU")^D GPTX8"KRN" ,.402,2138 ,"ROUOLD") DGPTX8"KRN ",.402,224 3,-1)0^9"K RN",.402,2 243,0)DG50 1-10D^3180 112.0952^" @"^45^^"@" ^3180116"K RN",.402,2 243,"AR",4 5.02,1173) 1^DGX510"K RN",.402,2 243,"AR",4 5.02,1174) 2^DGX510"K RN",.402,2 243,"AR",4 5.02,1175) 3^DGX510"K RN",.402,2 243,"AR",4 5.02,1176) 4^DGX510"K RN",.402,2 243,"AR",4 5.02,1177) 5^DGX510"K RN",.402,2 243,"AR",4 5.02,1178) 6^DGX510"K RN",.402,2 243,"AR",4 5.02,1179) 7^DGX510"K RN",.402,2 243,"AR",4 5.02,1180) 8^DGX510"K RN",.402,2 243,"AR",4 5.02,1181) 9^DGX510"K RN",.402,2 243,"AR",4 5.02,1182) 10^DGX510" KRN",.402, 2243,"AR", 45.02,1221 )11^DGX510 "KRN",.402 ,2243,"AR" ,45.02,122 2)12^DGX51 0"KRN",.40 2,2243,"AR ",45.02,12 23)13^DGX5 10"KRN",.4 02,2243,"A R",45.02,1 224)14^DGX 510"KRN",. 402,2243," AR",45.02, 1225)15^DG X510"KRN", .402,2243, "AR",45.02 ,1226)16^D GX510"KRN" ,.402,2243 ,"AR",45.0 2,1227)17^ DGX510"KRN ",.402,224 3,"AR",45. 02,1228)18 ^DGX510"KR N",.402,22 43,"AR",45 .02,1229)1 9^DGX510"K RN",.402,2 243,"AR",4 5.02,1230) 20^DGX510" KRN",.402, 2243,"AR", 45.02,1231 )21^DGX510 "KRN",.402 ,2243,"AR" ,45.02,123 2)22^DGX51 0"KRN",.40 2,2243,"AR ",45.02,12 33)23^DGX5 10"KRN",.4 02,2243,"A R",45.02,1 234)24^DGX 510"KRN",. 402,2243," AR",45.02, 1235)25^DG X510"KRN", .402,2243, "DIAB",1,1 ,45.02,1)T REATED FOR  SC CONDIT ION//NO;"W AS TREATME NT FOR A S ERVICE CON NECTED CON DITION?""K RN",.402,2 243,"DIAB" ,1,1,45.02 ,30)TREATE D FOR AO C ONDITION;" WAS TREATM ENT RELATE D TO AGENT  ORANGE EX POSURE?""K RN",.402,2 243,"DIAB" ,1,1,45.02 ,31)EXPOSE D TO SW AS IA CONDITI ONS;"WAS T REATMENT R ELATED TO  SERVICE IN  SW ASIA?" "KRN",.402 ,2243,"DIA B",1,1,45. 02,32)29;" WAS TREATM ENT RELATE D TO MILIT ARY SEXUAL  TRAUMA?"" KRN",.402, 2243,"DIAB ",1,1,45.0 2,34)PATIE NT MOVEMEN T:"KRN",.4 02,2243,"D IAB",2,1,4 5.02,34)33 //^S X=DGX ;"WAS TREA TMENT RELA TED TO CAM P LEJEUNE? ""KRN",.40 2,2243,"DI AB",5,1,45 .02,29)POT ENTIALLY R ELATED TO  COMBAT//YE S;"WAS TRE ATMENT REL ATED TO CO MBAT?""KRN ",.402,224 3,"DIAB",7 ,1,45.02,3 0)TREATED  FOR IR CON DITION;"WA S TREATMEN T RELATED  TO IONIZIN G RADIATIO N EXPOSURE ?""KRN",.4 02,2243,"D IAB",7,1,4 5.02,31)32 ;"WAS TREA TMENT RELA TED TO PRO J 112/SHAD ?""KRN",.4 02,2243,"D IAB",7,1,4 5.02,32)30 ;"WAS TREA TMENT RELA TED TO HEA D AND/OR N ECK CANCER ?""KRN",.4 02,2243,"D R",1,45)F  X=2:1:7 S  DGDUP(X)=0 ;K DGPTIT; I $G(DGPTF )<1 S DGPT F=D0 W !!, "Editing P TF Record  "_DGPTF_"  in VA File Manager."; I $G(DGMOV )<1 S DGMO V=1 W !!," Editing Di scharge Mo vement in  VA FileMan ager";I $G (DFN)<1 S  DFN=+$G(^D GPT(D0,0)) ;"KRN",.40 2,2243,"DR ",1,45,1)D  CENSUS^DG PTIC10(DA) ;S DGJUMP= $G(DGJUMP) ;S DGXX="" ,DGTYPE=$P (^DGPT(D0, 0),U,11),D GCODSYS=$$ CODESYS^DG PTIC10(D0) ;S DGHOLD= $G(^DGPT(D GPTF,"M",+ DGMOV,0)), DGHOLD1=$G (^(81));50 ///^S X=+D GMOV;"KRN" ,.402,2243 ,"DR",2,45 .02)S:'$D( DGADD) DGA DD=0;S:DGJ UMP'[1 Y=" @2";S:DGAD D Y="@20"; S DGNFLD=" @10";3;@10 ;S DGNFLD= "@15";4;I  $D(^DPT(+^ DGPT(DGPTF ,0),.3)),$ P(^(.3),U) ="Y" S Y=" @15";18/// /^S X=2;S  (DGNFLD,Y) ="@20";@15 ;"KRN",.40 2,2243,"DR ",2,45.02, 1)18WAS TR EATMENT FO R A SERVIC E CONNECTE D CONDITIO N?~//NO;@2 0;S:DGJUMP '[2 Y="";@ 2;S DGNFLD ="@25";S Y ="@9000";@ 25;I DGADD ,$P(DGHOLD ,U,5)]"" S  Y="@40";S  DGNFLD="@ 40";5;S DG XX=X;I DGX X="" S Y=" @26";82.01 ;@26;S X=D GXX;"KRN", .402,2243, "DR",2,45. 02,2)I X K  DGPTIT S  DGNFLD="@4 0",Y="@800 0",DGPTIT( X_$C(59)_" ICD9(")="" ;@40;I DGA DD,$P(DGHO LD,U,6)]""  S Y="@50" ;S DGNFLD= "@50";6;S  DGXX=X;I D GXX="" S Y ="@41";82. 02;@41;S X =DGXX;"KRN ",.402,224 3,"DR",2,4 5.02,3)I X  K DGPTIT  S DGNFLD=" @50",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@50;I D GADD,$P(DG HOLD,U,7)] "" S Y="@6 0";S DGNFL D="@60";7; S DGXX=X;I  DGXX="" S  Y="@51";8 2.03;@51;S  X=DGXX;"K RN",.402,2 243,"DR",2 ,45.02,4)I  X K DGPTI T S DGNFLD ="@60",Y=" @8000",DGP TIT(X_$C(5 9)_"ICD9(" )="";@60;I  DGADD,$P( DGHOLD,U,8 )]"" S Y=" @70";S DGN FLD="@70"; 8;S DGXX=X ;I DGXX=""  S Y="@61" ;82.04;@61 ;S X=DGXX; "KRN",.402 ,2243,"DR" ,2,45.02,5 )I X K DGP TIT S DGNF LD="@70",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@70 ;I DGADD,$ P(DGHOLD,U ,9)]"" S Y ="@80";S D GNFLD="@80 ";9;S DGXX =X;I DGXX= "" S Y="@7 1";82.05;@ 71;S X=DGX X;"KRN",.4 02,2243,"D R",2,45.02 ,6)I X K D GPTIT S DG NFLD="@80" ,Y="@8000" ,DGPTIT(X_ $C(59)_"IC D9(")="";@ 80;I DGCOD SYS="ICD9" !(DGTYPE=2 ) S Y="@28 0";I DGADD ,$P(DGHOLD ,U,11)]""  S Y="@90"; S DGNFLD=" @90";11;S  DGXX=X;I D GXX="" S Y ="@81";82. 06;@81;S X =DGXX;"KRN ",.402,224 3,"DR",2,4 5.02,7)I X  K DGPTIT  S DGNFLD=" @90",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@90;I D GADD,$P(DG HOLD,U,12) ]"" S Y="@ 100";S DGN FLD="@100" ;12;S DGXX =X;I DGXX= "" S Y="@9 1";82.07;@ 91;S X=DGX X;"KRN",.4 02,2243,"D R",2,45.02 ,8)I X K D GPTIT S DG NFLD="@100 ",Y="@8000 ",DGPTIT(X _$C(59)_"I CD9(")=""; @100;I DGA DD,$P(DGHO LD,U,13)]" " S Y="@11 0";S DGNFL D="@110";1 3;S DGXX=X ;I DGXX=""  S Y="@101 ";82.08;@1 01;S X=DGX X;"KRN",.4 02,2243,"D R",2,45.02 ,9)I X K D GPTIT S DG NFLD="@110 ",Y="@8000 ",DGPTIT(X _$C(59)_"I CD9(")=""; @110;I DGA DD,$P(DGHO LD,U,14)]" " S Y="@12 0";S DGNFL D="@120";1 4;S DGXX=X ;I DGXX=""  S Y="@111 ";82.09;@1 11;S X=DGX X;"KRN",.4 02,2243,"D R",2,45.02 ,10)I X K  DGPTIT S D GNFLD="@12 0",Y="@800 0",DGPTIT( X_$C(59)_" ICD9(")="" ;@120;I DG ADD,$P(DGH OLD,U,15)] "" S Y="@1 30";S DGNF LD="@130"; 15;S DGXX= X;I DGXX=" " S Y="@12 1";82.1;@1 21;S X=DGX X;"KRN",.4 02,2243,"D R",2,45.02 ,11)I X K  DGPTIT S D GNFLD="@13 0",Y="@800 0",DGPTIT( X_$C(59)_" ICD9(")="" ;@130;I DG ADD,$P(DGH OLD1,U,1)] "" S Y="@1 40";S DGNF LD="@140"; 81.01;S DG XX=X;I DGX X="" S Y=" @131";82.1 1;@131;S X =DGXX;"KRN ",.402,224 3,"DR",2,4 5.02,12)I  X K DGPTIT  S DGNFLD= "@140",Y=" @8000",DGP TIT(X_$C(5 9)_"ICD9(" )="";@140; I DGADD,$P (DGHOLD1,U ,2)]"" S Y ="@150";S  DGNFLD="@1 50";81.02; S DGXX=X;I  DGXX="" S  Y="@141"; 82.12;@141 ;S X=DGXX; "KRN",.402 ,2243,"DR" ,2,45.02,1 3)I X K DG PTIT S DGN FLD="@150" ,Y="@8000" ,DGPTIT(X_ $C(59)_"IC D9(")="";@ 150;I DGAD D,$P(DGHOL D1,U,3)]""  S Y="@160 ";S DGNFLD ="@160";81 .03;S DGXX =X;I DGXX= "" S Y="@1 51";82.13; @151;S X=D GXX;"KRN", .402,2243, "DR",2,45. 02,14)I X  K DGPTIT S  DGNFLD="@ 160",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@160;I  DGADD,$P(D GHOLD1,U,4 )]"" S Y=" @170";S DG NFLD="@170 ";81.04;S  DGXX=X;I D GXX="" S Y ="@161";82 .14;@161;S  X=DGXX;"K RN",.402,2 243,"DR",2 ,45.02,15) I X K DGPT IT S DGNFL D="@170",Y ="@8000",D GPTIT(X_$C (59)_"ICD9 (")="";@17 0;I DGADD, $P(DGHOLD1 ,U,5)]"" S  Y="@180"; S DGNFLD=" @180";81.0 5;S DGXX=X ;I DGXX=""  S Y="@171 ";82.15;@1 71;S X=DGX X;"KRN",.4 02,2243,"D R",2,45.02 ,16)I X K  DGPTIT S D GNFLD="@18 0",Y="@800 0",DGPTIT( X_$C(59)_" ICD9(")="" ;@180;I DG ADD,$P(DGH OLD1,U,6)] "" S Y="@1 90";S DGNF LD="@190"; 81.06;S DG XX=X;I DGX X="" S Y=" @181";82.1 6;@181;S X =DGXX;"KRN ",.402,224 3,"DR",2,4 5.02,17)I  X K DGPTIT  S DGNFLD= "@190",Y=" @8000",DGP TIT(X_$C(5 9)_"ICD9(" )="";@190; I DGADD,$P (DGHOLD1,U ,7)]"" S Y ="@200";S  DGNFLD="@2 00";81.07; S DGXX=X;I  DGXX="" S  Y="@191"; 82.17;@191 ;S X=DGXX; "KRN",.402 ,2243,"DR" ,2,45.02,1 8)I X K DG PTIT S DGN FLD="@200" ,Y="@8000" ,DGPTIT(X_ $C(59)_"IC D9(")="";@ 200;I DGAD D,$P(DGHOL D1,U,8)]""  S Y="@210 ";S DGNFLD ="@210";81 .08;S DGXX =X;I DGCOD SYS="ICD9" !(DGTYPE=2 )!(DGXX="" ) S Y="@20 1";82.18;@ 201;S X=DG XX;"KRN",. 402,2243," DR",2,45.0 2,19)I X K  DGPTIT S  DGNFLD="@2 10",Y="@80 00",DGPTIT (X_$C(59)_ "ICD9(")=" ";@210;I D GADD,$P(DG HOLD1,U,9) ]"" S Y="@ 220";S DGN FLD="@220" ;81.09;S D GXX=X;I DG XX="" S Y= "@211";82. 19;@211;S  X=DGXX;"KR N",.402,22 43,"DR",2, 45.02,20)I  X K DGPTI T S DGNFLD ="@220",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@220 ;I DGADD,$ P(DGHOLD1, U,10)]"" S  Y="@230"; S DGNFLD=" @230";81.1 ;S DGXX=X; I DGXX=""  S Y="@221" ;82.2;@221 ;S X=DGXX; "KRN",.402 ,2243,"DR" ,2,45.02,2 1)I X K DG PTIT S DGN FLD="@230" ,Y="@8000" ,DGPTIT(X_ $C(59)_"IC D9(")="";@ 230;I DGAD D,$P(DGHOL D1,U,11)]" " S Y="@24 0";S DGNFL D="@240";8 1.11;S DGX X=X;I DGXX ="" S Y="@ 231";82.21 ;@231;S X= DGXX;"KRN" ,.402,2243 ,"DR",2,45 .02,22)I X  K DGPTIT  S DGNFLD=" @240",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@240;I  DGADD,$P( DGHOLD1,U, 12)]"" S Y ="@250";S  DGNFLD="@2 50";81.12; S DGXX=X;I  DGXX="" S  Y="@241"; 82.22;@241 ;S X=DGXX; "KRN",.402 ,2243,"DR" ,2,45.02,2 3)I X K DG PTIT S DGN FLD="@250" ,Y="@8000" ,DGPTIT(X_ $C(59)_"IC D9(")="";@ 250;I DGAD D,$P(DGHOL D1,U,13)]" " S Y="@26 0";S DGNFL D="@260";8 1.13;S DGX X=X;I DGXX ="" S Y="@ 251";82.23 ;@251;S X= DGXX;"KRN" ,.402,2243 ,"DR",2,45 .02,24)I X  K DGPTIT  S DGNFLD=" @260",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@260;I  DGADD,$P( DGHOLD1,U, 14)]"" S Y ="@270";S  DGNFLD="@2 70";81.14; S DGXX=X;I  DGXX="" S  Y="@261"; 82.24;@261 ;S X=DGXX; "KRN",.402 ,2243,"DR" ,2,45.02,2 5)I X K DG PTIT S DGN FLD="@270" ,Y="@8000" ,DGPTIT(X_ $C(59)_"IC D9(")="";@ 270;I DGAD D,$P(DGHOL D1,U,15)]" " S Y="@28 0";S DGNFL D="@280";8 1.15;S DGX X=X;I DGXX ="" S Y="@ 271";82.25 ;@271;S X= DGXX;"KRN" ,.402,2243 ,"DR",2,45 .02,26)I X  K DGPTIT  S DGNFLD=" @280",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@280;K  DGNFLD,DG DUP,DGADD  S Y="";@80 00;D SCAN^ DGPTSCAN S :'$D(DGBPC ) Y="@8990 ";I '$D(DG BPC(2))!(D GDUP(2)) S  Y="@8100" ;300.02;S: X]"" DGDUP (2)=1;@810 0;"KRN",.4 02,2243,"D R",2,45.02 ,27)I '$D( DGBPC(3))! (DGDUP(3))  S Y="@820 0";300.03; S:X]"" DGD UP(3)=1;@8 200;I '$D( DGBPC(4))! (DGDUP(4))  S Y="@830 0";D DRUG^ DGPTSC01 I  $D(DGTX)  S Y="@8250 ";300.04;S :X]"" DGDU P(4)=1;S Y ="@8300";@ 8250;300.0 4//^S X=DG TX;S:X]""  DGDUP(4)=1 ;"KRN",.40 2,2243,"DR ",2,45.02, 28)@8300;I  '$D(DGBPC (5))!(DGDU P(5)) S Y= "@8400";30 0.05;S:X]" " DGDUP(5) =1;@8400;I  '$D(DGBPC (6))!(DGDU P(6)) S Y= "@8500";30 0.06;S:X]" " DGDUP(6) =1;@8500;I  '$D(DGBPC (7))!(DGDU P(7)) S Y= "@8990";30 0.07;S:X]" " DGDUP(7) =1;@8990;" KRN",.402, 2243,"DR", 2,45.02,29 )K DGPTIT, DGTX S Y=D GNFLD;@900 0;K DGEXQ  D CHQUES^D GPTSPQ I ' $D(DGEXQ)  S Y="@9999 ";I '$D(DG EXQ(6)) S  Y="@9040"; 31WAS TREA TMENT RELA TED TO COM BAT?~//YES ;S Y="@905 0";@9040;3 1///@;@905 0;I '$D(DG EXQ(1)) S  Y="@9100"; "KRN",.402 ,2243,"DR" ,2,45.02,3 0)26WAS TR EATMENT RE LATED TO A GENT ORANG E EXPOSURE ?~;S Y="@9 150";@9100 ;26///@;@9 150;I '$D( DGEXQ(2))  S Y="@9200 ";27WAS TR EATMENT RE LATED TO I ONIZING RA DIATION EX POSURE?~;S  Y="@9250" ;@9200;27/ //@;@9250; I '$D(DGEX Q(3)) S Y= "@9300";"K RN",.402,2 243,"DR",2 ,45.02,31) 28WAS TREA TMENT RELA TED TO SER VICE IN SW  ASIA?~;S  Y="@9350"; @9300;28// /@;@9350;I  '$D(DGEXQ (7)) S Y=" @9400";32W AS TREATME NT RELATED  TO PROJ 1 12/SHAD?~; S Y="@9450 ";@9400;32 ///@;@9450 ;I '$D(DGE XQ(4)) S Y ="@9500";" KRN",.402, 2243,"DR", 2,45.02,32 )29WAS TRE ATMENT REL ATED TO MI LITARY SEX UAL TRAUMA ?~;S Y="@9 550";@9500 ;29///@;@9 550;I '$D( DGEXQ(5))  S Y="@9600 ";30WAS TR EATMENT RE LATED TO H EAD AND/OR  NECK CANC ER?~;I X[" Y",$D(DFN) ,$$FILEHNC ^DGNTAPI1( DFN);S Y=" @9650";@96 00;30///@; "KRN",.402 ,2243,"DR" ,2,45.02,3 3)@9650;I  '$D(DGEXQ( 8)) S Y="@ 9700";S:$$ GETCL^DGUT L3(DFN)'=1  Y="@9700" ;"KRN",.40 2,2243,"DR ",2,45.02, 34)^405^DG PM(^^S I(1 ,0)=$G(D1) ,I(0,0)=$G (D0),D0=$O (^DGPM("AP TF",I(0,0) ,0)) S:$O( ^(D0))>0 D 0=0 S X=$S (D0>0:D0,1 :""),D(0)= X S D0=I(0 ,0) S D1=I (1,0) S X= $S(D(0)>0: D(0),1:"") ;33WAS TRE ATMENT REL ATED TO CA MP LEJEUNE ?~//^S X=D GX;"KRN",. 402,2243," DR",2,45.0 2,35)S Y=" @9750";@97 00;33///@; @9750;@999 9;K DGEXQ  S Y=DGNFLD ;"KRN",.40 2,2243,"DR ",3,405)K  DGX S DGX= $P(^DGPT(D GPTF,"M",+ $G(DGMOV), 0),U,33);I  $G(DGX)'= "" S X=$S( $G(DGX)="Y ":"YES",1: "NO"),Y="@ 28";S DGX= $S($P(^DGP M(DA,"CLV" ),U,1)="Y" :"YES",1:" NO");@28;" KRN",.402, 2243,"DR", 99,1)S I(1 ,0)=$G(D1) ,I(0,0)=$G (D0),D0=$O (^DGPM("AP TF",I(0,0) ,0)) S:$O( ^(D0))>0 D 0=0 S X=$S (D0>0:D0,1 :""),D(0)= X S D0=I(0 ,0) S D1=I (1,0)"KRN" ,.402,2243 ,"DR",99,1 ,9.2)N DIA DD,DIC S D IC=405,DIC (0)="",DIC ("S")="I $ D(^DGPM("" APTF"","_I (0,0)_",Y) )" D ^DIC  S D0=+Y,DI C(.16)=I(0 ,0),DIH=40 5 D DICL^D ICR:$P(Y,U ,3)"KRN",. 402,2243," ROU")^DGX5 "KRN",.402 ,2243,"ROU OLD")DGX5" KRN",.402, 2245,-1)0^ 10"KRN",.4 02,2245,0) DG501F-10D ^3180112.0 954^@^45^^ @^3180115" KRN",.402, 2245,"AR", 45.02,1173 )1^DGX5FD1 0"KRN",.40 2,2245,"AR ",45.02,11 74)2^DGX5F D10"KRN",. 402,2245," AR",45.02, 1175)3^DGX 5FD10"KRN" ,.402,2245 ,"AR",45.0 2,1176)4^D GX5FD10"KR N",.402,22 45,"AR",45 .02,1177)5 ^DGX5FD10" KRN",.402, 2245,"AR", 45.02,1178 )6^DGX5FD1 0"KRN",.40 2,2245,"AR ",45.02,11 79)7^DGX5F D10"KRN",. 402,2245," AR",45.02, 1180)8^DGX 5FD10"KRN" ,.402,2245 ,"AR",45.0 2,1181)9^D GX5FD10"KR N",.402,22 45,"AR",45 .02,1182)1 0^DGX5FD10 "KRN",.402 ,2245,"AR" ,45.02,122 1)11^DGX5F D10"KRN",. 402,2245," AR",45.02, 1222)12^DG X5FD10"KRN ",.402,224 5,"AR",45. 02,1223)13 ^DGX5FD10" KRN",.402, 2245,"AR", 45.02,1224 )14^DGX5FD 10"KRN",.4 02,2245,"A R",45.02,1 225)15^DGX 5FD10"KRN" ,.402,2245 ,"AR",45.0 2,1226)16^ DGX5FD10"K RN",.402,2 245,"AR",4 5.02,1227) 17^DGX5FD1 0"KRN",.40 2,2245,"AR ",45.02,12 28)18^DGX5 FD10"KRN", .402,2245, "AR",45.02 ,1229)19^D GX5FD10"KR N",.402,22 45,"AR",45 .02,1230)2 0^DGX5FD10 "KRN",.402 ,2245,"AR" ,45.02,123 1)21^DGX5F D10"KRN",. 402,2245," AR",45.02, 1232)22^DG X5FD10"KRN ",.402,224 5,"AR",45. 02,1233)23 ^DGX5FD10" KRN",.402, 2245,"AR", 45.02,1234 )24^DGX5FD 10"KRN",.4 02,2245,"A R",45.02,1 235)25^DGX 5FD10"KRN" ,.402,2245 ,"DIAB",1, 1,45.02,1) TREATED FO R SC CONDI TION//NO;" WAS TREATM ENT FOR A  SERVICE CO NNECTED CO NDITION?"" KRN",.402, 2245,"DIAB ",1,1,45.0 2,30)TREAT ED FOR AO  CONDITION; "WAS TREAT MENT RELAT ED TO AGEN T ORANGE E XPOSURE?"" KRN",.402, 2245,"DIAB ",1,1,45.0 2,31)EXPOS ED TO SW A SIA CONDIT IONS;"WAS  TREATMENT  RELATED TO  SERVICE I N SW ASIA? ""KRN",.40 2,2245,"DI AB",1,1,45 .02,32)29; "WAS TREAT MENT RELAT ED TO MILI TARY SEXUA L TRAUMA?" "KRN",.402 ,2245,"DIA B",5,1,45. 02,29)POTE NTIALLY RE LATED TO C OMBAT//YES ;"WAS TREA TMENT RELA TED TO COM BAT?""KRN" ,.402,2245 ,"DIAB",5, 1,45.02,33 )33//"NO"; "WAS TREAT MENT RELAT ED TO CAMP  LEJEUNE?" "KRN",.402 ,2245,"DIA B",7,1,45. 02,30)TREA TED FOR IR  CONDITION ;"WAS TREA TMENT RELA TED TO ION IZING RADI ATION EXPO SURE?""KRN ",.402,224 5,"DIAB",7 ,1,45.02,3 1)32;"WAS  TREATMENT  RELATED TO  PROJ 112/ SHAD?""KRN ",.402,224 5,"DIAB",7 ,1,45.02,3 2)30;"WAS  TREATMENT  RELATED TO  HEAD AND/ OR NECK CA NCER?""KRN ",.402,224 5,"DR",1,4 5)F X=2:1: 7 S DGDUP( X)=0;K DGP TIT;I $G(D GPTF)<1 S  DGPTF=D0 W  !!,"Editi ng PTF Rec ord "_DGPT F_" in VA  FileManage r.";I $G(D GMOV)<1 S  DGMOV=1 W  !!,"Editin g Discharg e Movement  in VA Fil eManager"; I $G(DFN)< 1 S DFN=+$ G(^DGPT(D0 ,0));"KRN" ,.402,2245 ,"DR",1,45 ,1)D CENSU S^DGPTIC10 (DA);S DGJ UMP=$G(DGJ UMP);S DGX X="",DGTYP E=$P(^DGPT (D0,0),U,1 1),DGCODSY S=$$CODESY S^DGPTIC10 (D0);S DGH OLD=$G(^DG PT(DGPTF," M",+DGMOV, 0)) S:DGHO LD]"" DGHO LD1=$G(^(8 1));S:'$D( DGADD) DGA DD=0;S DGN FLD="@10"; "KRN",.402 ,2245,"DR" ,1,45,2)50 ///^S X=+D GMOV;"KRN" ,.402,2245 ,"DR",2,45 .02)S:DGJU MP'[1 Y="@ 2";10;@10; S DGNFLD=" @15";2;@15 ;S DGNFLD= "@16";3;@1 6;S DGNFLD ="@17";4;@ 17;S:DGJUM P'[2 Y=0;@ 2;I $D(^DP T(+^DGPT(D GPTF,0),.3 )),$P(^(.3 ),U)="Y" S  (DGNFLD,Y )="@25";18 ////^S X=2 ;S (DGNFLD ,Y)="@27"; @25;"KRN", .402,2245, "DR",2,45. 02,1)18WAS  TREATMENT  FOR A SER VICE CONNE CTED CONDI TION?~//NO ;@27;S DGN FLD="@28"; S Y="@9000 ";@28;I DG ADD,$P(DGH OLD,U,5)]" " S Y="@40 ";S DGNFLD ="@40";5;S  DGXX=X;I  DGXX="" S  Y="@26";82 .01;@26;S  X=DGXX;"KR N",.402,22 45,"DR",2, 45.02,2)I  X K DGPTIT  S DGNFLD= "@40",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@40;I  DGADD,$P(D GHOLD,U,6) ]"" S Y="@ 50";S DGNF LD="@50";6 ;S DGXX=X; I DGXX=""  S Y="@41"; 82.02;@41; S X=DGXX;" KRN",.402, 2245,"DR", 2,45.02,3) I X K DGPT IT S DGNFL D="@50",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@50; I DGADD,$P (DGHOLD,U, 7)]"" S Y= "@60";S DG NFLD="@60" ;7;S DGXX= X;I DGXX=" " S Y="@51 ";82.03;@5 1;S X=DGXX ;"KRN",.40 2,2245,"DR ",2,45.02, 4)I X K DG PTIT S DGN FLD="@60", Y="@8000", DGPTIT(X_$ C(59)_"ICD 9(")="";@6 0;I DGADD, $P(DGHOLD, U,8)]"" S  Y="@70";S  DGNFLD="@7 0";8;S DGX X=X;I DGXX ="" S Y="@ 61";82.04; @61;S X=DG XX;"KRN",. 402,2245," DR",2,45.0 2,5)I X K  DGPTIT S D GNFLD="@70 ",Y="@8000 ",DGPTIT(X _$C(59)_"I CD9(")=""; @70;I DGAD D,$P(DGHOL D,U,9)]""  S Y="@80"; S DGNFLD=" @80";9;S D GXX=X;I DG XX="" S Y= "@71";82.0 5;@71;S X= DGXX;"KRN" ,.402,2245 ,"DR",2,45 .02,6)I X  K DGPTIT S  DGNFLD="@ 80",Y="@80 00",DGPTIT (X_$C(59)_ "ICD9(")=" ";@80;I DG ADD,$P(DGH OLD,U,11)] "" S Y="@9 0";S DGNFL D="@90";11 ;S DGXX=X; I DGXX=""  S Y="@81"; 82.06;@81; S X=DGXX;" KRN",.402, 2245,"DR", 2,45.02,7) I X K DGPT IT S DGNFL D="@90",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@90; I DGADD,$P (DGHOLD,U, 12)]"" S Y ="@100";S  DGNFLD="@1 00";12;S D GXX=X;I DG XX="" S Y= "@91";82.0 7;@91;S X= DGXX;"KRN" ,.402,2245 ,"DR",2,45 .02,8)I X  K DGPTIT S  DGNFLD="@ 100",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@100;I  DGADD,$P(D GHOLD,U,13 )]"" S Y=" @110";S DG NFLD="@110 ";13;S DGX X=X;I DGXX ="" S Y="@ 101";82.08 ;@101;S X= DGXX;"KRN" ,.402,2245 ,"DR",2,45 .02,9)I X  K DGPTIT S  DGNFLD="@ 110",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@110;I  DGADD,$P(D GHOLD,U,14 )]"" S Y=" @120";S DG NFLD="@120 ";14;S DGX X=X;I DGXX ="" S Y="@ 111";82.09 ;@111;S X= DGXX;"KRN" ,.402,2245 ,"DR",2,45 .02,10)I X  K DGPTIT  S DGNFLD=" @120",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@120;I  DGADD,$P( DGHOLD,U,1 5)]"" S Y= "@130";S D GNFLD="@13 0";15;S DG XX=X;I DGX X="" S Y=" @121";82.1 ;@121;S X= DGXX;"KRN" ,.402,2245 ,"DR",2,45 .02,11)I X  K DGPTIT  S DGNFLD=" @130",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@130;I  DGADD,$P( DGHOLD1,U, 1)]"" S Y= "@140";S D GNFLD="@14 0";81.01;S  DGXX=X;I  DGXX="" S  Y="@131";8 2.11;@131; S X=DGXX;" KRN",.402, 2245,"DR", 2,45.02,12 )I X K DGP TIT S DGNF LD="@140", Y="@8000", DGPTIT(X_$ C(59)_"ICD 9(")="";@1 40;I DGADD ,$P(DGHOLD 1,U,2)]""  S Y="@150" ;S DGNFLD= "@150";81. 02;S DGXX= X;I DGXX=" " S Y="@14 1";82.12;@ 141;S X=DG XX;"KRN",. 402,2245," DR",2,45.0 2,13)I X K  DGPTIT S  DGNFLD="@1 50",Y="@80 00",DGPTIT (X_$C(59)_ "ICD9(")=" ";@150;I D GADD,$P(DG HOLD1,U,3) ]"" S Y="@ 160";S DGN FLD="@160" ;81.03;S D GXX=X;I DG XX="" S Y= "@151";82. 13;@151;S  X=DGXX;"KR N",.402,22 45,"DR",2, 45.02,14)I  X K DGPTI T S DGNFLD ="@160",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@160 ;I DGADD,$ P(DGHOLD1, U,4)]"" S  Y="@170";S  DGNFLD="@ 170";81.04 ;S DGXX=X; I DGXX=""  S Y="@161" ;82.14;@16 1;S X=DGXX ;"KRN",.40 2,2245,"DR ",2,45.02, 15)I X K D GPTIT S DG NFLD="@170 ",Y="@8000 ",DGPTIT(X _$C(59)_"I CD9(")=""; @170;I DGA DD,$P(DGHO LD1,U,5)]" " S Y="@18 0";S DGNFL D="@180";8 1.05;S DGX X=X;I DGXX ="" S Y="@ 171";82.15 ;@171;S X= DGXX;"KRN" ,.402,2245 ,"DR",2,45 .02,16)I X  K DGPTIT  S DGNFLD=" @180",Y="@ 8000",DGPT IT(X_$C(59 )_"ICD9(") ="";@180;I  DGADD,$P( DGHOLD1,U, 6)]"" S Y= "@190";S D GNFLD="@19 0";81.06;S  DGXX=X;I  DGXX="" S  Y="@181";8 2.16;@181; S X=DGXX;" KRN",.402, 2245,"DR", 2,45.02,17 )I X K DGP TIT S DGNF LD="@190", Y="@8000", DGPTIT(X_$ C(59)_"ICD 9(")="";@1 90;I DGADD ,$P(DGHOLD 1,U,7)]""  S Y="@200" ;S DGNFLD= "@200";81. 07;S DGXX= X;I DGXX=" " S Y="@19 1";82.17;@ 191;S X=DG XX;"KRN",. 402,2245," DR",2,45.0 2,18)I X K  DGPTIT S  DGNFLD="@2 00",Y="@80 00",DGPTIT (X_$C(59)_ "ICD9(")=" ";@200;I D GADD,$P(DG HOLD1,U,8) ]"" S Y="@ 210";S DGN FLD="@210" ;81.08;S D GXX=X;I DG XX="" S Y= "@201";82. 18;@201;S  X=DGXX;"KR N",.402,22 45,"DR",2, 45.02,19)I  X K DGPTI T S DGNFLD ="@210",Y= "@8000",DG PTIT(X_$C( 59)_"ICD9( ")="";@210 ;I DGADD,$ P(DGHOLD1, U,9)]"" S  Y="@220";S  DGNFLD="@ 220";81.09 ;S DGXX=X; I DGXX=""  S Y="@211" ;82.19;@21 1;S X=DGXX ;"KRN",.40 2,2245,"DR ",2,45.02, 20)I X K D GPTIT S DG NFLD="@220 ",Y="@8000 ",DGPTIT(X _$C(59)_"I CD9(")=""; @220;I DGA DD,$P(DGHO LD1,U,10)] "" S Y="@2 30";S DGNF LD="@230"; 81.1;S DGX X=X;I DGXX ="" S Y="@ 221";82.2; @221;S X=D GXX;"KRN", .402,2245, "DR",2,45. 02,21)I X  K DGPTIT S  DGNFLD="@ 230",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@230;I  DGADD,$P(D GHOLD1,U,1 1)]"" S Y= "@240";S D GNFLD="@24 0";81.11;S  DGXX=X;I  DGXX="" S  Y="@231";8 2.21;@231; S X=DGXX;" KRN",.402, 2245,"DR", 2,45.02,22 )I X K DGP TIT S DGNF LD="@240", Y="@8000", DGPTIT(X_$ C(59)_"ICD 9(")="";@2 40;I DGADD ,$P(DGHOLD 1,U,12)]""  S Y="@250 ";S DGNFLD ="@250";81 .12;S DGXX =X;I DGXX= "" S Y="@2 41";82.22; @241;S X=D GXX;"KRN", .402,2245, "DR",2,45. 02,23)I X  K DGPTIT S  DGNFLD="@ 250",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@250;I  DGADD,$P(D GHOLD1,U,1 3)]"" S Y= "@260";S D GNFLD="@26 0";81.13;S  DGXX=X;I  DGXX="" S  Y="@251";8 2.23;@251; S X=DGXX;" KRN",.402, 2245,"DR", 2,45.02,24 )I X K DGP TIT S DGNF LD="@260", Y="@8000", DGPTIT(X_$ C(59)_"ICD 9(")="";@2 60;I DGADD ,$P(DGHOLD 1,U,14)]""  S Y="@270 ";S DGNFLD ="@270";81 .14;S DGXX =X;I DGXX= "" S Y="@2 61";82.24; @261;S X=D GXX;"KRN", .402,2245, "DR",2,45. 02,25)I X  K DGPTIT S  DGNFLD="@ 270",Y="@8 000",DGPTI T(X_$C(59) _"ICD9(")= "";@270;I  DGADD,$P(D GHOLD1,U,1 5)]"" S Y= "@280";S D GNFLD="@28 0";81.15;S  DGXX=X;I  DGXX="" S  Y="@271";8 2.25;@271; S X=DGXX;" KRN",.402, 2245,"DR", 2,45.02,26 )I X K DGP TIT S DGNF LD="@280", Y="@8000", DGPTIT(X_$ C(59)_"ICD 9(")="";@2 80;K DGNFL D,DGDUP,DG ADD,DGXX,D GCODSYS S  Y="";@8000 ;D SCAN^DG PTSCAN S:' $D(DGBPC)  Y="@8990"; I '$D(DGBP C(2))!(DGD UP(2)) S Y ="@8200";3 00.02;S:X] "" DGDUP(2 )=1;@8200; "KRN",.402 ,2245,"DR" ,2,45.02,2 7)I '$D(DG BPC(3))!(D GDUP(3)) S  Y="@8300" ;300.03;S: X]"" DGDUP (3)=1;@830 0;I '$D(DG BPC(4))!(D GDUP(4)) S  Y="@8400" ;D DRUG^DG PTSC01 I $ D(DGTX) S  Y="@8350"; 300.04;S:X ]"" DGDUP( 4)=1;S Y=" @8400";@83 50;300.04/ /^S X=DGTX ;S:X]"" DG DUP(4)=1;" KRN",.402, 2245,"DR", 2,45.02,28 )@8400;I ' $D(DGBPC(5 ))!(DGDUP( 5)) S Y="@ 8500";300. 05;S:X]""  DGDUP(5)=1 ;@8500;I ' $D(DGBPC(6 ))!(DGDUP( 6)) S Y="@ 8600";300. 06;S:X]""  DGDUP(6)=1 ;@8600;I ' $D(DGBPC(7 ))!(DGDUP( 7)) S Y="@ 8990";300. 07;S:X]""  DGDUP(7)=1 ;@8990;"KR N",.402,22 45,"DR",2, 45.02,29)K  DGPTIT S  Y=DGNFLD;@ 9000;K DGE XQ D CHQUE S^DGPTSPQ  I '$D(DGEX Q) S Y="@9 999";I '$D (DGEXQ(6))  S Y="@904 0";31WAS T REATMENT R ELATED TO  COMBAT?~// YES;S Y="@ 9050";@904 0;31///@;@ 9050;I '$D (DGEXQ(1))  S Y="@910 0";"KRN",. 402,2245," DR",2,45.0 2,30)26WAS  TREATMENT  RELATED T O AGENT OR ANGE EXPOS URE?~;S Y= "@9150";@9 100;26///@ ;@9150;I ' $D(DGEXQ(2 )) S Y="@9 200";27WAS  TREATMENT  RELATED T O IONIZING  RADIATION  EXPOSURE? ~;S Y="@92 50";@9200; 27///@;@92 50;I '$D(D GEXQ(3)) S  Y="@9300" ;"KRN",.40 2,2245,"DR ",2,45.02, 31)28WAS T REATMENT R ELATED TO  SERVICE IN  SW ASIA?~ ;S Y="@935 0";@9300;2 8///@;@935 0;I '$D(DG EXQ(7)) S  Y="@9400"; 32WAS TREA TMENT RELA TED TO PRO J 112/SHAD ?~;S Y="@9 450";@9400 ;32///@;@9 450;I '$D( DGEXQ(4))  S Y="@9500 ";"KRN",.4 02,2245,"D R",2,45.02 ,32)29WAS  TREATMENT  RELATED TO  MILITARY  SEXUAL TRA UMA?~;S Y= "@9550";@9 500;29///@ ;@9550;I ' $D(DGEXQ(5 )) S Y="@9 600";30WAS  TREATMENT  RELATED T O HEAD AND /OR NECK C ANCER?~;I  X["Y",$D(D FN),$$FILE HNC^DGNTAP I1(DFN);S  Y="@9650"; @9600;30// /@;"KRN",. 402,2245," DR",2,45.0 2,33)@9650 ;I '$D(DGE XQ(8)) S Y ="@9700";S :$$GETCL^D GUTL3(DFN) '=1 Y="@97 00";Q;33WA S TREATMEN T RELATED  TO CAMP LE JEUNE?~//^ S X="NO";S  Y="@9750" ;@9700;33/ //@;@9750; @9999;K DG EXQ S Y=DG NFLD;@9999 9;"KRN",.4 02,2245,"R OU")^DGX5F D"KRN",.40 2,2245,"RO UOLD")DGX5 FD"MBREQ") 0"ORD",7,. 402).402;7 ;;;EDEOUT^ DIFROMSO(. 402,DA,"", XPDA);FPRE ^DIFROMSI( .402,"",XP DA);EPRE^D IFROMSI(.4 02,DA,$E(" N",$G(XPDN EW)),XPDA, "",OLDA);; EPOST^DIFR OMSI(.402, DA,"",XPDA );DEL^DIFR OMSK(.402, "",%)"ORD" ,7,.402,0) INPUT TEMP LATE"PKG", 114,-1)1^1 "PKG",114, 0)REGISTRA TION^DG^PA TIENT REGI STRATION,  ADMISSION,  DISCHARGE , EMBOSSER  "PKG",114 ,20,0)^9.4 02P^^"PKG" ,114,22,0) ^9.49I^1^1 "PKG",114, 22,1,0)5.3 ^2930813^2 930821"PKG ",114,22,1 ,"PAH",1,0 )914^31801 23^1000000 0007"PKG", 114,22,1," PAH",1,1,0 )^^1^1^318 0123"PKG", 114,22,1," PAH",1,1,1 ,0)Please  refer to t he patch d escription  for detai ls."QUES", "XPF1",0)Y "QUES","XP F1","??")^ D REP^XPDH "QUES","XP F1","A")Sh all I writ e over you r |FLAG| F ile"QUES", "XPF1","B" )YES"QUES" ,"XPF1","M ")D XPF1^X PDIQ"QUES" ,"XPF2",0) Y"QUES","X PF2","??") ^D DTA^XPD H"QUES","X PF2","A")W ant my dat a |FLAG| y ours"QUES" ,"XPF2","B ")YES"QUES ","XPF2"," M")D XPF2^ XPDIQ"QUES ","XPI1",0 )YO"QUES", "XPI1","?? ")^D INHIB IT^XPDH"QU ES","XPI1" ,"A")Want  KIDS to IN HIBIT LOGO Ns during  the instal l"QUES","X PI1","B")N O"QUES","X PI1","M")D  XPI1^XPDI Q"QUES","X PM1",0)PO^ VA(200,:EM "QUES","XP M1","??")^ D MG^XPDH" QUES","XPM 1","A")Ent er the Coo rdinator f or Mail Gr oup '|FLAG |'"QUES"," XPM1","B") "QUES","XP M1","M")D  XPM1^XPDIQ "QUES","XP O1",0)Y"QU ES","XPO1" ,"??")^D M ENU^XPDH"Q UES","XPO1 ","A")Want  KIDS to R ebuild Men u Trees Up on Complet ion of Ins tall"QUES" ,"XPO1","B ")NO"QUES" ,"XPO1","M ")D XPO1^X PDIQ"QUES" ,"XPZ1",0) Y"QUES","X PZ1","??") ^D OPT^XPD H"QUES","X PZ1","A")W ant to DIS ABLE Sched uled Optio ns, Menu O ptions, an d Protocol s"QUES","X PZ1","B")N O"QUES","X PZ1","M")D  XPZ1^XPDI Q"QUES","X PZ2",0)Y"Q UES","XPZ2 ","??")^D  RTN^XPDH"Q UES","XPZ2 ","A")Want  to MOVE r outines to  other CPU s"QUES","X PZ2","B")N O"QUES","X PZ2","M")D  XPZ2^XPDI Q"RTN")29" RTN","DGAP I1")0^6^B2 5401406"RT N","DGAPI1 ",1,0)DGAP I1 ;ALB/DW S - DG API  TO COMUNI CATE WITH  PCE ;6/16/ 05 1:44pm" RTN","DGAP I1",2,0) ; ;5.3;Regis tration;** 635,664,91 4**;Aug 13 , 1993;Bui ld 104"RTN ","DGAPI1" ,3,0)DATA2 PCE(DFN,PT F,DGZP) ;S END CPT PR OCEDURE TR ANSACTIONS  TO PCE"RT N","DGAPI1 ",4,0) ;"R TN","DGAPI 1",5,0) N  DGVISIT,DR ,DIE,DA,X, Y"RTN","DG API1",6,0)  ;"RTN","D GAPI1",7,0 ) D BUILD" RTN","DGAP I1",8,0) ; "RTN","DGA PI1",9,0)  I $P($G(DG ZPRF(DGZP) ),U,6) S D GVISIT=$P( DGZPRF(DGZ P),U,6)"RT N","DGAPI1 ",10,0) ;" RTN","DGAP I1",11,0)  I $D(DGREL ) S DGRELS V=DGREL ;s ave DGREL,  it gets k illed off  in SCDXMSG 1"RTN","DG API1",12,0 ) S RES=$$ DATA2PCE^P XAPI("^TMP (""DGPCE1" ",$J,""PXA PI"")",107 ,"801 SCRE EN",.DGVIS IT)"RTN"," DGAPI1",13 ,0) I $D(D GRELSV) S  DGREL=DGRE LSV K DGRE LSV ;resto re DGREL"R TN","DGAPI 1",14,0) ; "RTN","DGA PI1",15,0)  D:$D(^TMP ("DGPCE1", $J,"PXAPI" ,"DIERR"))  ERR"RTN", "DGAPI1",1 6,0) ;"RTN ","DGAPI1" ,17,0) K ^ TMP("DGPCE 1",$J,"PXA PI")"RTN", "DGAPI1",1 8,0) ;"RTN ","DGAPI1" ,19,0) ;"R TN","DGAPI 1",20,0) Q :RES<-1 RE S"RTN","DG API1",21,0 ) ;"RTN"," DGAPI1",22 ,0) S DR=" .06////"_D GVISIT_";. 07////1",D IE="^DGPT( "_PTF_","" C"",",DA=D GZPRF(DGZP ,0),DA(1)= PTF D ^DIE "RTN","DGA PI1",23,0)  ;"RTN","D GAPI1",24, 0) Q RES"R TN","DGAPI 1",25,0) ; "RTN","DGA PI1",26,0) ERR ; look s to see i f there is  an truly  an error"R TN","DGAPI 1",27,0) N  DGX,DGQ"R TN","DGAPI 1",28,0) S  (DGQ,DGX) =0 F  S DG X=$O(^TMP( "DGPCE1",$ J,"PXAPI", "DIERR",$J ,DGX)) Q:' DGX!(DGQ)   I $E($G(^ TMP("DGPCE 1",$J,"PXA PI","DIERR ",$J,DGX," TEXT",1)), 1,5)="ERRO R" S DGQ=1  D ERRMSG( DGX)"RTN", "DGAPI1",2 9,0) Q"RTN ","DGAPI1" ,30,0) ;"R TN","DGAPI 1",31,0)ER RMSG(DGX)  ; sends th e error me ssage"RTN" ,"DGAPI1", 32,0) N XM DUZ,XMSUB, XMTEXT,XMY ,XMZ,XMMG, DGL,DGTXT, DGY"RTN"," DGAPI1",33 ,0) ;"RTN" ,"DGAPI1", 34,0) D DE M^VADPT"RT N","DGAPI1 ",35,0) ;" RTN","DGAP I1",36,0)  S XMDUZ="P TF MODULE" ,XMSUB="80 1 to PCE f iling erro r""RTN","D GAPI1",37, 0) S XMY(" G.DG PTF 8 01 TO PCE  ERROR")="" ,XMY(DUZ)= "",XMTEXT= "DGTXT(""R TN","DGAPI 1",38,0) ; "RTN","DGA PI1",39,0)  S DGTXT(1 ,0)="An er ror has oc curred whi le sending  PTF 801 d ata to PCE .""RTN","D GAPI1",40, 0) S DGTXT (2,0)=" "" RTN","DGAP I1",41,0)  S DGTXT(3, 0)="     P atient Nam e:  "_VADM (1)"RTN"," DGAPI1",42 ,0) S DGTX T(4,0)="      Social  Security:   "_$P(VADM (2),"^",2) "RTN","DGA PI1",43,0)  S DGTXT(5 ,0)="      Date/Time:   "_$$FMTE ^XLFDT(+DG ZPRF(DGZP) )"RTN","DG API1",44,0 ) S DGTXT( 6,0)="      Location:   "_$P($G( ^SC($P(DGZ PRF(DGZP), "^",5),0)) ,"^")"RTN" ,"DGAPI1", 45,0) S DG TXT(7,0)="  ""RTN","D GAPI1",46, 0) ;"RTN", "DGAPI1",4 7,0) S DGL =7,DGY=0 F   S DGY=$O (^TMP("DGP CE1",$J,"P XAPI","DIE RR",$J,DGX ,"TEXT",DG Y)) Q:'DGY !($E(^TMP( "DGPCE1",$ J,"PXAPI", "DIERR",$J ,DGX,"TEXT ",DGY),1,2 5)="^TMP(" "DGPCE1"", $J,""PXAPI "")")  D"R TN","DGAPI 1",48,0) .  S DGL=DGL +1,DGTXT(D GL,0)="      "_^TMP(" DGPCE1",$J ,"PXAPI"," DIERR",$J, DGX,"TEXT" ,DGY)"RTN" ,"DGAPI1", 49,0) ;"RT N","DGAPI1 ",50,0) D  ^XMD"RTN", "DGAPI1",5 1,0) D KVA R^VADPT"RT N","DGAPI1 ",52,0) ;" RTN","DGAP I1",53,0)  Q"RTN","DG API1",54,0 ) ;"RTN"," DGAPI1",55 ,0)DELVFIL E(DFN,PTF, DGZP) ;DEL ETE VISIT  IN PCE WHE N A CHANGE  IS MADE"R TN","DGAPI 1",56,0) N  DIE,DA,DR  S RES=1"R TN","DGAPI 1",57,0) S :$P(DGZPRF (DGZP),U,7 ) RES=$$DE LVFILE^PXA PI("ALL",$ P(DGZPRF(D GZP),U,6)) "RTN","DGA PI1",58,0)  S DA=DGZP RF(DGZP,0) ,DA(1)=PTF "RTN","DGA PI1",59,0)  S DIE="^D GPT("_PTF_ ",""C"",", DR=".06/// @;.07////0 " D ^DIE"R TN","DGAPI 1",60,0) Q  RES"RTN", "DGAPI1",6 1,0) ;"RTN ","DGAPI1" ,62,0)BUIL D ; now bu ild array  for passin g data to  PCE"RTN"," DGAPI1",63 ,0) N DGAP I,DGC,DGPR OC,DGPROCZ ,DGP,DGDXN O,DGDXC,DG DX,DGX"RTN ","DGAPI1" ,64,0) K ^ TMP("DGPCE 1",$J,"PXA PI") S DGD XC=0"RTN", "DGAPI1",6 5,0) S DGA PI=$NA(^TM P("DGPCE1" ,$J,"PXAPI "))"RTN"," DGAPI1",66 ,0) ; ---- -----encou nter date/ time------ ---------- "RTN","DGA PI1",67,0)  S @DGAPI@ ("ENCOUNTE R",1,"ENC  D/T")=+DGZ PRF(DGZP)" RTN","DGAP I1",68,0)  ; -------- ------pati ent------- ---------- ------"RTN ","DGAPI1" ,69,0) S @ DGAPI@("EN COUNTER",1 ,"PATIENT" )=DFN"RTN" ,"DGAPI1", 70,0) ; -- ---------- ---locatio n--------- ---------- --"RTN","D GAPI1",71, 0) S @DGAP I@("ENCOUN TER",1,"HO S LOC")=$P (DGZPRF(DG ZP),"^",5) "RTN","DGA PI1",72,0)  ; ------- -------ser vice categ ory------- -------"RT N","DGAPI1 ",73,0) S  @DGAPI@("E NCOUNTER", 1,"SERVICE  CATEGORY" )="I""RTN" ,"DGAPI1", 74,0) ; -- ---------- ---encount er type--- ---------- --"RTN","D GAPI1",75, 0) S @DGAP I@("ENCOUN TER",1,"EN COUNTER TY PE")="P""R TN","DGAPI 1",76,0) ;  --------- ---primary  provider- ---------- -----"RTN" ,"DGAPI1", 77,0) S @D GAPI@("PRO VIDER",1," NAME")=$P( DGZPRF(DGZ P),"^",3)" RTN","DGAP I1",78,0)  S @DGAPI@( "PROVIDER" ,1,"PRIMAR Y")=1"RTN" ,"DGAPI1", 79,0) ; -- ---------- secondary  provider-- ---------- -"RTN","DG API1",80,0 ) I $P(DGZ PRF(DGZP), "^",2),$P( DGZPRF(DGZ P),"^",2)' =$P(DGZPRF (DGZP),"^" ,3) S @DGA PI@("PROVI DER",2,"NA ME")=$P(DG ZPRF(DGZP) ,"^",2)"RT N","DGAPI1 ",81,0) ;  ---------- ------proc edures---- ---------- ---"RTN"," DGAPI1",82 ,0) S DGC= 0,DGPROC=0  F  S DGPR OC=$O(DGZP RF(DGZP,DG PROC)) Q:' DGPROC  D" RTN","DGAP I1",83,0)  . S DGPROC Z=$G(DGZPR F(DGZP,DGP ROC)) Q:'D GPROCZ"RTN ","DGAPI1" ,84,0) . S  DGC=DGC+1 ,@DGAPI@(" PROCEDURE" ,DGC,"PROC EDURE")=+D GPROCZ"RTN ","DGAPI1" ,85,0) . ;  --------- -----modif iers------ ---------- --"RTN","D GAPI1",86, 0) . F DGP =2,3 I $P( DGPROCZ,"^ ",DGP) S @ DGAPI@("PR OCEDURE",D GC,"MODIFI ERS",$P($$ MOD^ICPTMO D($P(DGPRO CZ,"^",DGP ),"I",+DGZ PRF(DGZP)) ,"^",2))=" ""RTN","DG API1",87,0 ) . ; ---- ---------- quantity-- ---------- -------"RT N","DGAPI1 ",88,0) .  S @DGAPI@( "PROCEDURE ",DGC,"QTY ")=$P(DGPR OCZ,"^",14 )"RTN","DG API1",89,0 ) . ; ---- ---------- diagnosis- ---------- -------"RT N","DGAPI1 ",90,0) .  F DGP=4:1: 7,15:1:18  I $P(DGPRO CZ,"^",DGP ) D"RTN"," DGAPI1",91 ,0) . . S  DGDXNO=$S( DGP=4:"",D GP<15:DGP- 3,1:DGP-11 )"RTN","DG API1",92,0 ) . . S @D GAPI@("PRO CEDURE",DG C,"DIAGNOS IS"_$S(DGD XNO<2:"",1 :" "_DGDXN O))=$P(DGP ROCZ,"^",D GP)"RTN"," DGAPI1",93 ,0) . . I  $D(DGDX($P (DGPROCZ," ^",DGP)))  Q"RTN","DG API1",94,0 ) . . S DG DX($P(DGPR OCZ,"^",DG P))="",DGD XC=DGDXC+1 "RTN","DGA PI1",95,0)  . . S @DG API@("DX/P L",DGDXC," DIAGNOSIS" )=$P(DGPRO CZ,"^",DGP )"RTN","DG API1",96,0 ) . . S:DG DXC=1 @DGA PI@("DX/PL ",DGDXC,"P RIMARY")=1 "RTN","DGA PI1",97,0)  . . S (DG Y,DGX)=0 F   S DGX=$O (^DGICD9(4 6.1,"C",PT F,DGX)) Q: 'DGX!(DGY)   I +$G(^D GICD9(46.1 ,DGX,0))=$ P(DGPROCZ, "^",DGP) S  DGY=DGX"R TN","DGAPI 1",98,0) .  . S DGY=$ G(^DGICD9( 46.1,+DGY, 0))"RTN"," DGAPI1",99 ,0) . . I  $L($P(DGY, "^",2)) S  @DGAPI@("D X/PL",DGDX C,"PL SC") =$P(DGY,"^ ",2)"RTN", "DGAPI1",1 00,0) . .  I $L($P(DG Y,"^",3))  S @DGAPI@( "DX/PL",DG DXC,"PL AO ")=$P(DGY, "^",3)"RTN ","DGAPI1" ,101,0) .  . I $L($P( DGY,"^",4) ) S @DGAPI @("DX/PL", DGDXC,"PL  IR")=$P(DG Y,"^",4)"R TN","DGAPI 1",102,0)  . . I $L($ P(DGY,"^", 5)) S @DGA PI@("DX/PL ",DGDXC,"P L EC")=$P( DGY,"^",5) "RTN","DGA PI1",103,0 ) . . I $L ($P(DGY,"^ ",6)) S @D GAPI@("DX/ PL",DGDXC, "PL MST")= $P(DGY,"^" ,6)"RTN"," DGAPI1",10 4,0) . . I  $L($P(DGY ,"^",7)) S  @DGAPI@(" DX/PL",DGD XC,"PL HNC ")=$P(DGY, "^",7)"RTN ","DGAPI1" ,105,0) .  . I $L($P( DGY,"^",8) ) S @DGAPI @("DX/PL", DGDXC,"PL  CV")=$P(DG Y,"^",8)"R TN","DGAPI 1",106,0)  . . I $L($ P(DGY,"^", 9)) S @DGA PI@("DX/PL ",DGDXC,"P L SHAD")=$ P(DGY,"^", 9)"RTN","D GAPI1",107 ,0) . . I  $L($P(DGY, "^",10)) S  @DGAPI@(" DX/PL",DGD XC,"PL CLV ")=$P(DGY, "^",10)"RT N","DGAPI1 ",108,0) ; JMM DG*5.3 *914 RSD 2 .6.5.3.3.4 , 2.6.5.2. 5.2 and 2. 6.5.4.1 Ad d "PL CLV"  line abov e to inclu de Camp Le jeune in d ata sent t o PCE"RTN" ,"DGAPI1", 109,0) Q"R TN","DGAPI 1",110,0)  ;"RTN","DG ENCLEA")0^ 67^B230517 10"RTN","D GENCLEA",1 ,0)DGENCLE A ;ALB/JLS  - Camp Le jeune Elig ibility AP I - Retrie ve Eligibi lity ;11/2 8/14 4:25p m"RTN","DG ENCLEA",2, 0) ;;5.3;R egistratio n;**909,91 4**;Aug 13 ,1993;Buil d 104"RTN" ,"DGENCLEA ",3,0) ;"R TN","DGENC LEA",4,0)  ; Business  Rules to  determine  Camp Lejeu ne Eligibi lity:"RTN" ,"DGENCLEA ",5,0) ;.  Person is  a Veteran  AND"RTN"," DGENCLEA", 6,0) ;  .  Either ("R ule 1") "R TN","DGENC LEA",7,0)  ;    . Has  one Milit ary Servic e Episode  (DGMSE) be tween, and  inclusive  of, Aug 1 , 1953 and  Dec 31, 1 987 and "R TN","DGENC LEA",8,0)  ;    . The  identifie d DGMSE ha s a charac ter of dis charge oth er than"RT N","DGENCL EA",9,0) ;       . Di shonorable "RTN","DGE NCLEA",10, 0) ;       . Other Th an Honorab le"RTN","D GENCLEA",1 1,0) ;       . Undesi rable"RTN" ,"DGENCLEA ",12,0) ;       . Bad  Conduct"R TN","DGENC LEA",13,0)  ;      .  Dishonorab le-VA"RTN" ,"DGENCLEA ",14,0) ;A ND"RTN","D GENCLEA",1 5,0) ;     . The iden tified DGM SE is at l east 30 da ys in dura tion"RTN", "DGENCLEA" ,16,0) ;   . OR ("Rul e 2"; perf orm this c heck only  if "Rule 1 " was not  met)"RTN", "DGENCLEA" ,17,0) ;     . Has mo re than on e Military  Service E pisodes (D GMSEs) bet ween, and  inclusive  of, Aug 1,  1953 and  Dec 31, 19 87 AND "RT N","DGENCL EA",18,0)  ;    . All  of the id entified D GMSEs have  a charact er of disc harge othe r than "RT N","DGENCL EA",19,0)  ;      . D ishonorabl e"RTN","DG ENCLEA",20 ,0) ;       . Other T han Honora ble "RTN", "DGENCLEA" ,21,0) ;       . Unde sirable"RT N","DGENCL EA",22,0)  ;      . B ad Conduct "RTN","DGE NCLEA",23, 0) ;       . Dishonor able-VA"RT N","DGENCL EA",24,0)  ;AND"RTN", "DGENCLEA" ,25,0) ;     . The su m of two o r more of  the identi fied DGMSE s add up t o at least  30 days i n duration  (meaning  that it do es not hav e to be co nsecutive  days)"RTN" ,"DGENCLEA ",26,0) ;" RTN","DGEN CLEA",27,0 ) ;  Input s: DFN"RTN ","DGENCLE A",28,0) ;  Outputs:  CLE return s 1 if pat ient is ca mp lejeune  eligible,  returns 0  if not ca mp lejeune  eligible" RTN","DGEN CLEA",29,0 ) ;  0 - C LE "Not El igible""RT N","DGENCL EA",30,0)  ;  1 - CLE  "Eligible ""RTN","DG ENCLEA",31 ,0) ;"RTN" ,"DGENCLEA ",32,0)CLE (DFN) ;"RT N","DGENCL EA",33,0)  K DGMSE"RT N","DGENCL EA",34,0)  ; Is patie nt a veter an VET1 Is  the patie nt an elig ible veter an VET"RTN ","DGENCLE A",35,0) I  '$$VET^DG ENPTA(DFN)  Q 0"RTN", "DGENCLEA" ,36,0) ; I f primary  eligibilit y code exi sts it mus t be a Vet eran Type  Eligibilit y Code fro m File 8 " RTN","DGEN CLEA",37,0 ) N DGPRIE L"RTN","DG ENCLEA",38 ,0) S DGPR IEL=$P($G( ^DPT(DFN,. 36)),U,1)" RTN","DGEN CLEA",39,0 ) I DGPRIE L]"",$P($G (^DIC(8,DG PRIEL,0)), U,5)="N" Q  0"RTN","D GENCLEA",4 0,0) ; Get  DGMSE dat a from DGM SE sub-fil e #2.3216  first, if  that does  not exist  get DGMSE  data from  .32 node"R TN","DGENC LEA",41,0)  N DGMSE"R TN","DGENC LEA",42,0)  I $D(^DPT (DFN,.3216 )) D GETMS E^DGMSEUTL (DFN,.DGMS E)"RTN","D GENCLEA",4 3,0) I $G( DGMSE)=""  S DGMSE=$G (^DPT(DFN, .32))"RTN" ,"DGENCLEA ",44,0) I  '$D(DGMSE)  Q 0"RTN", "DGENCLEA" ,45,0) ; L oop throug h DGMSE to  find at l east 1 qua lifying DG MSE  (CLE= 1)"RTN","D GENCLEA",4 6,0) N DGE NTDT,DGEXI TDT,DGTYPE ,DGLOOP,DG CLE,DGCLSR DT,X1,X2"R TN","DGENC LEA",47,0)  S (DGCLE, DGCLSRDT)= 0"RTN","DG ENCLEA",48 ,0) S DGLO OP="" F  S  DGLOOP=$O (DGMSE(DGL OOP)) Q:(D GLOOP="")! (DGCLE=1)   D"RTN","D GENCLEA",4 9,0) . S ( DGENTDT,DG EXITDT,DGT YPE,X1,X2) ="""RTN"," DGENCLEA", 50,0) . S  DGENTDT=$$ FMTH^XLFDT ($P(DGMSE( DGLOOP),"^ ",1),1),DG EXITDT=$$F MTH^XLFDT( $P(DGMSE(D GLOOP),"^" ,2),1),DGT YPE=$P(DGM SE(DGLOOP) ,"^",6)"RT N","DGENCL EA",51,0)  . ;automat ically qui t out of t his DGMSE  if Dischar ge is 2,4, 5,6,8 or n ull"RTN"," DGENCLEA", 52,0) . ;F ile #25 (D ishonorabl e,Other Th an Dishono rable,Unde sirable,Ba d Conduct, Dishonorab le-VA"RTN" ,"DGENCLEA ",53,0) .  Q:(DGTYPE= 2)!(DGTYPE =4)!(DGTYP E=5)!(DGTY PE=6)!(DGT YPE=8)!(DG TYPE="")"R TN","DGENC LEA",54,0)  . ;automa tically qu it out if  DGMSE is N OT within  date range "RTN","DGE NCLEA",55, 0) . ;0801 1953 and 1 2311987"RT N","DGENCL EA",56,0)  . ;$H 4112 0(subtract ed +1 to b e 'inclusi ve') and 5 3690(added  +1 to be  'inclusive ')"RTN","D GENCLEA",5 7,0) . ;FM  2530801 a nd 2871231 "RTN","DGE NCLEA",58, 0) . Q:(DG ENTDT>5369 0)!(DGEXIT DT<41120)    ;if eith er date is  out of CL E date ran ge do not  continue ( ineligible )"RTN","DG ENCLEA",59 ,0) . I DG ENTDT<4112 0 S DGENTD T=41120  ; only inclu de Entry D ates start ing from C LE date ra nge"RTN"," DGENCLEA", 60,0) . I  DGEXITDT>5 3690 S DGE XITDT=5369 0    ;only  include E xit Dates  ending at  CLE date r ange"RTN", "DGENCLEA" ,61,0) . S  X1=$$HTFM ^XLFDT($G( DGEXITDT)) ,X2=$$HTFM ^XLFDT($G( DGENTDT))  D ^%DTC S  DGCLSRDT=D GCLSRDT+(X +1)"RTN"," DGENCLEA", 62,0) . ;a utomatical ly quit ou t if DGMSE  is NOT gr eater than  30 days"R TN","DGENC LEA",63,0)  . Q:DGCLS RDT<30"RTN ","DGENCLE A",64,0) .  S DGCLE=1 "RTN","DGE NCLEA",65, 0) Q DGCLE "RTN","DGE NCLEA",66, 0) ;"RTN", "DGENCLEA" ,67,0)ADDE DTCL(DFN)  ; DG*5.3*9 09 Enter/E dit Camp L ejeune Ind icator"RTN ","DGENCLE A",68,0) ;  changed v eteran to  Veteran  p wc - DG*5. 3*914 Camp  Lejeune " RTN","DGEN CLEA",69,0 ) ;"RTN"," DGENCLEA", 70,0)AECL2  N DGCLIND ,DGCLOLD,D GSITE,X,Y" RTN","DGEN CLEA",71,0 ) K DIR S  DIR(0)="YO ""RTN","DG ENCLEA",72 ,0) S DIR( "A")="CAMP  LEJEUNE W ATER CONTA MINANT EXP OSURE INDI CATED""RTN ","DGENCLE A",73,0) S  DGCLOLD=$ P($G(^DPT( DFN,.3217) ),U,1)"RTN ","DGENCLE A",74,0) S  DIR("B")= $S(DGCLOLD ="Y":"YES" ,DGCLOLD=" N":"NO",1: "")"RTN"," DGENCLEA", 75,0) K:DI R("B")=""  DIR("B")"R TN","DGENC LEA",76,0)  S DIR("?" ,1)="Enter  "_$C(34)_ "Y"_$C(34) _" if Vete ran claims  need ""RT N","DGENCL EA",77,0)  S DIR("?", 1)=DIR("?" ,1)_"for c are of con ditions re lated to e xposure of ""RTN","DG ENCLEA",78 ,0) S DIR( "?",2)=$C( 34)_"Water  Contamina tion at Ca mp Lejeune "_$C(34)"R TN","DGENC LEA",79,0)  S DIR("?" ,2)=DIR("? ",2)_". En ter "_$C(3 4)_"N"_$C( 34)_" if V eteran ""R TN","DGENC LEA",80,0)  S DIR("?" ,2)=DIR("? ",2)_"was  not assign ed to""RTN ","DGENCLE A",81,0) S  DIR("?",3 )="Camp Le jeune betw een August  1, 1953 a nd Decembe r 31, ""RT N","DGENCL EA",82,0)  S DIR("?", 3)=DIR("?" ,3)_"1987  or does no t claim ne ed""RTN"," DGENCLEA", 83,0) S DI R("?",4)=" for care o f conditio ns related  to exposu re of "_$C (34)"RTN", "DGENCLEA" ,84,0) S D IR("?",4)= DIR("?",4) _"Water Co ntaminatio n at Camp" "RTN","DGE NCLEA",85, 0) S DIR(" ?",5)="Lej eune"_$C(3 4)_".""RTN ","DGENCLE A",86,0) S  DIR("?",6 )="Choose  from:",DIR ("?",7)="Y  YES",DIR( "?",8)="N  NO""RTN"," DGENCLEA", 87,0) S DI R("?")="Nu ll "_$C(34 )_"Blank"_ $C(34)"RTN ","DGENCLE A",88,0) D  ^DIR K DI R"RTN","DG ENCLEA",89 ,0) I X="@ " D  G AEC L2"RTN","D GENCLEA",9 0,0) . W ! !,"Camp Le jeune indi cator cann ot be dele ted if alr eady ""RTN ","DGENCLE A",91,0) .  W "indica ted.",!,"E nter '^' t o exit.",! "RTN","DGE NCLEA",92, 0) S DGCLI ND=$S(Y=1: "Y",Y=0:"N ",1:Y)"RTN ","DGENCLE A",93,0) Q :DGCLIND=" ^"  Q:"^Y^ N^"'[(U_DG CLIND_U) " RTN","DGEN CLEA",94,0 ) S DGSITE =$P($$SITE ^VASITE,U, 3)"RTN","D GENCLEA",9 5,0) D SAV ECL(DFN,DG CLIND,$P($ $NOW^XLFDT ,".",1),DG SITE,"VAMC ")"RTN","D GENCLEA",9 6,0) Q"RTN ","DGENCLE A",97,0) ; "RTN","DGE NCLEA",98, 0)SAVECL(D FN,DGCLIND ,DGCLDAT,D GSITE,DGSO URCE) ; DG *5.3*909 S ave CL-V i nfo"RTN"," DGENCLEA", 99,0) ; Ch eck if CL- V Indicato r already  No or Yes,  then use  old date." RTN","DGEN CLEA",100, 0) N DGCLV REC S DGCL VREC=$G(^D PT(DFN,.32 17))"RTN", "DGENCLEA" ,101,0) I  "^Y^N^"[(U _$P(DGCLVR EC,U)_U),$ P(DGCLVREC ,U,2)]"" D "RTN","DGE NCLEA",102 ,0) . S DG CLDAT=$P(D GCLVREC,U, 2)"RTN","D GENCLEA",1 03,0) S ^D PT(DFN,.32 17)=DGCLIN D_U_DGCLDA T_U_DGSITE _U_DGSOURC E"RTN","DG ENCLEA",10 4,0) Q"RTN ","DGENCLE A",105,0)  ;"RTN","DG ENCLEA",10 6,0)SETCLN O ; DG*5.3 *909 Set C amp Lejeun e to No wh en no long er CL Elig ible"RTN", "DGENCLEA" ,107,0) Q: $P($G(^DPT (DFN,.3217 )),U,1)'=" Y""RTN","D GENCLEA",1 08,0) Q:$G (^DPT(DFN, .32171))=1     ; if L ocked then  don't cha nge YES to  NO"RTN"," DGENCLEA", 109,0) N D GCLE S DGC LE=$$CLE(D FN) Q:DGCL E"RTN","DG ENCLEA",11 0,0) D SAV ECL(DFN,"N ",$P($$NOW ^XLFDT,"." ,1),$P($$S ITE^VASITE ,U,3),"VAM C")"RTN"," DGENCLEA", 111,0) D A UTOUPD^DGE NA2(DFN)"R TN","DGENC LEA",112,0 ) Q"RTN"," DGENCLEA", 113,0) ;"R TN","DGPTA EE1")0^69^ B43310874" RTN","DGPT AEE1",1,0) DGPTAEE1 ; ALB/MTC,HI OFO/FT - A ustin Edit s EAL List ing Contin ued ;12/4/ 14 3:05pm" RTN","DGPT AEE1",2,0)  ;;5.3;Reg istration; **338,565, 678,729,66 4,884,914* *;Aug 13,  1993;Build  104"RTN", "DGPTAEE1" ,3,0) ;"RT N","DGPTAE E1",4,0) ; no externa l referenc es"RTN","D GPTAEE1",5 ,0) ;"RTN" ,"DGPTAEE1 ",6,0) ;DG PTLINE=1 i s icd9 lay out"RTN"," DGPTAEE1", 7,0) ;DGPT LINE=2 is  icd10 layo ut"RTN","D GPTAEE1",8 ,0)H101(RE C) ;-- 101  header // patch 850  made the n eeded chan ges for 10 1 so 884 d id have to  modify th is subrout ine. ft 12 /2/14"RTN" ,"DGPTAEE1 ",9,0) ; I NPUT : REC  - Node th at contain s the erro r"RTN","DG PTAEE1",10 ,0) N I,X, X1,X2"RTN" ,"DGPTAEE1 ",11,0) S  X="ADM     SSN        ADM-DATE-T IME LAST-N AME     IN IT SOU FRO M  SOP POW  MS SX""RT N","DGPTAE E1",12,0)  S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",13,0) S  X=$E(REC,1 ,4)_"  "_$ E(REC,5,14 )_SP_$E(RE C,15,16)_S P_$E(REC,1 7,18)_SP_$ E(REC,19,2 0)_SP_$E(R EC,21,24)_ SP_$E(REC, 31,42)_"    "_$E(REC, 43,44)_"    "_$E(REC, 45,46)_SP_ $E(REC,47, 52)_SP_$E( REC,53)_"    "_$E(REC ,54)_"   " _$E(REC,55 )_"  "_$E( REC,56)"RT N","DGPTAE E1",14,0)  S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",15,0) S  X="",$P(X, " ",80)="  " F X1=1:1  S I=$P(DG ER,",",X1)  Q:I=""  I  $P(I,":") <12 S X2=+ $P(I,":",2 ),X=$E(X,1 ,X2-1)_"#" _$E(X,X2+1 ,80)"RTN", "DGPTAEE1" ,16,0) S V ALMCNT=VAL MCNT+1,^TM P("AD",$J, VALMCNT,0) =X"RTN","D GPTAEE1",1 7,0) ;;Cam p Lejeune  PWC - RSD  2.6.5.7 PT F Close ou t Screen D G*5.3*914  set to pie ce 100"RTN ","DGPTAEE 1",18,0) S  X="BIRTHD ATE    POS  AGO ION S T-CNTY  ZI P   MT INC OME MST CV  CV-END SH AD ERI CNT RY""RTN"," DGPTAEE1", 19,0) S VA LMCNT=VALM CNT+1,^TMP ("AD",$J,V ALMCNT,0)= X"RTN","DG PTAEE1",20 ,0) S X=$E (REC,57,58 )_SP_$E(RE C,59,60)_S P_$E(REC,6 1,64)_"    "_$E(REC,6 5,66)_"     "_$E(REC, 67)_"   "_ $E(REC,68) _"  "_$E(R EC,69,73)_ "  "_$E(RE C,74,78)_"   "_$E(REC ,79,80)_SP _$E(REC,81 ,86)_"  "_ $E(REC,87) _"   "_$E( REC,88)_"  "_$E(REC,8 9,94)"RTN" ,"DGPTAEE1 ",21,0) S  X=X_"    " _$E(REC,95 )_"  "_$E( REC,96)_"    "_$E(REC ,97,99)"RT N","DGPTAE E1",22,0)  S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",23,0) S  X="",$P(X, " ",80)="  " F X1=1:1  S I=$P(DG ER,",",X1)  Q:I=""  I  $P(I,":") >11 S X2=+ $P(I,":",2 ),X=$E(X,1 ,X2-1)_"#" _$E(X,X2+1 ,80)"RTN", "DGPTAEE1" ,24,0) S V ALMCNT=VAL MCNT+1,^TM P("AD",$J, VALMCNT,0) =X"RTN","D GPTAEE1",2 5,0) ;Camp  Lejeune P WC - RSD 2 .6.5.7 PTF  Close out  Screen DG *5.3*914 s et to piec e 100"RTN" ,"DGPTAEE1 ",26,0) ;A dd a blank  line"RTN" ,"DGPTAEE1 ",27,0) S  X="""RTN", "DGPTAEE1" ,28,0) S V ALMCNT=VAL MCNT+1,^TM P("AD",$J, VALMCNT,0) =X"RTN","D GPTAEE1",2 9,0) ;CL i nfo will a ppear on n ew line du e to lengt h of exist ing line"R TN","DGPTA EE1",30,0)  S X="CL"" RTN","DGPT AEE1",31,0 ) S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E1",32,0)  S X=" "_$E (REC,100,1 01)"RTN"," DGPTAEE1", 33,0) S VA LMCNT=VALM CNT+1,^TMP ("AD",$J,V ALMCNT,0)= X"RTN","DG PTAEE1",34 ,0) ; CL h as no edit  checks, j ust like S HAD"RTN"," DGPTAEE1", 35,0) D WR ER^DGPTAEE "RTN","DGP TAEE1",36, 0) Q"RTN", "DGPTAEE1" ,37,0) ;"R TN","DGPTA EE1",38,0) H401(REC)  ;-- 401 he ader"RTN", "DGPTAEE1" ,39,0) ; I NPUT : REC  - Node th at contain s the erro r"RTN","DG PTAEE1",40 ,0) N X,X1 ,X2"RTN"," DGPTAEE1", 41,0) S X= "SURG   SS N       AD M-DATE-TIM E SURG-DAT E-TIME  SP EC CATEG T ECH SOP""R TN","DGPTA EE1",42,0)  S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X"RTN ","DGPTAEE 1",43,0) S  X=$E(REC, 1,4)_"  "_ $E(REC,5,1 4)_SP_$E(R EC,15,16)_ SP_$E(REC, 17,18)_SP_ $E(REC,19, 20)_SP_$E( REC,21,24) _"  "_$E(R EC,31,32)_ SP_$E(REC, 33,34)_SP_ $E(REC,35, 36)_SP_$E( REC,37,40) _"   ""RTN ","DGPTAEE 1",44,0) S  X=X_$E(RE C,41,42)_"   "_$E(REC ,43)_"   " _$E(REC,44 )_"   "_$E (REC,45)_"    "_$E(RE C,46)"RTN" ,"DGPTAEE1 ",45,0) S  VALMCNT=VA LMCNT+1,^T MP("AD",$J ,VALMCNT,0 )=X"RTN"," DGPTAEE1", 46,0) S X= "",$P(X,"  ",80)=" "  F X1=1:1 S  I=$P(DGER ,",",X1) Q :I=""  I $ P(I,":")<9  S X2=+$P( I,":",2),X =$E(X,1,X2 -1)_"#"_$E (X,X2+1,80 )"RTN","DG PTAEE1",47 ,0) S VALM CNT=VALMCN T+1,^TMP(" AD",$J,VAL MCNT,0)=X" RTN","DGPT AEE1",48,0 ) I DGPTLI NE=1 D  ;i cd9 layout .  ft  12/ 2/14"RTN", "DGPTAEE1" ,49,0) .S  X="------- -----SURGI CAL CODES- ---------- --  PHY SS N   TRNSPL NT""RTN"," DGPTAEE1", 50,0) .S V ALMCNT=VAL MCNT+1,^TM P("AD",$J, VALMCNT,0) =X"RTN","D GPTAEE1",5 1,0) .S X= $E(REC,47, 53)_SP_$E( REC,54,60) _SP_$E(REC ,61,67)_SP _$E(REC,68 ,74)_SP_$E (REC,75,81 )_"  "_$E( REC,82,90) _"     "_$ E(REC,91)" RTN","DGPT AEE1",52,0 ) .S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE1",53,0)  .S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" "  I $P(I, ":")>8 S X 2=+$P(I,": ",2),X=$E( X,1,X2-1)_ "#"_$E(X,X 2+1,80)"RT N","DGPTAE E1",54,0)  .S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X"RTN ","DGPTAEE 1",55,0) I  DGPTLINE= 2 D  ;icd1 0 layout.   ft  12/2/ 14"RTN","D GPTAEE1",5 6,0) .S X= "--------- ---SURGICA L CODES--- ---------- ""RTN","DG PTAEE1",57 ,0) .S VAL MCNT=VALMC NT+1,^TMP( "AD",$J,VA LMCNT,0)=X "RTN","DGP TAEE1",58, 0) .S X=$E (REC,47,53 )_SP_$E(RE C,55,61)_S P_$E(REC,6 3,69)_SP_$ E(REC,71,7 7)_SP_$E(R EC,79,85)" RTN","DGPT AEE1",59,0 ) .S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE1",60,0)  .S X=$E(R EC,87,93)_ SP_$E(REC, 95,101)_SP _$E(REC,10 3,109)_SP_ $E(REC,111 ,117)_SP_$ E(REC,119, 125)"RTN", "DGPTAEE1" ,61,0) .S  VALMCNT=VA LMCNT+1,^T MP("AD",$J ,VALMCNT,0 )=X"RTN"," DGPTAEE1", 62,0) .S X =$E(REC,12 7,133)_SP_ $E(REC,135 ,141)_SP_$ E(REC,143, 149)_SP_$E (REC,151,1 57)_SP_$E( REC,159,16 7)"RTN","D GPTAEE1",6 3,0) .S VA LMCNT=VALM CNT+1,^TMP ("AD",$J,V ALMCNT,0)= X"RTN","DG PTAEE1",64 ,0) .S X=$ E(REC,167, 173)_SP_$E (REC,175,1 81)_SP_$E( REC,183,18 9)_SP_$E(R EC,191,197 )_SP_$E(RE C,199,205) "RTN","DGP TAEE1",65, 0) .S VALM CNT=VALMCN T+1,^TMP(" AD",$J,VAL MCNT,0)=X" RTN","DGPT AEE1",66,0 ) .S X=$E( REC,207,21 3)_SP_$E(R EC,215,221 )_SP_$E(RE C,223,229) _SP_$E(REC ,231,237)_ SP_$E(REC, 239,246)"R TN","DGPTA EE1",67,0)  .S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E1",68,0)  .S X="",$P (X," ",80) =" " F X1= 1:1 S I=$P (DGER,",", X1) Q:I=""   I $P(I," :")>8 S X2 =+$P(I,":" ,2),X=$E(X ,1,X2-1)_" #"_$E(X,X2 +1,80)"RTN ","DGPTAEE 1",69,0) . S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",70,0) D  WRER^DGPTA EE"RTN","D GPTAEE1",7 1,0) Q"RTN ","DGPTAEE 1",72,0) ; "RTN","DGP TAEE1",73, 0)H501(REC ) ;-- 501  header"RTN ","DGPTAEE 1",74,0) ;  INPUT : R EC - Node  that conta ins the er ror"RTN"," DGPTAEE1", 75,0) N X, X1,X2"RTN" ,"DGPTAEE1 ",76,0) S  X="DIAG    SSN        ADM-DATE-T IME MOVE D ATE-TIME M PCR CODE S PC LVE PAS S SCI""RTN ","DGPTAEE 1",77,0) S  VALMCNT=V ALMCNT+1,^ TMP("AD",$ J,VALMCNT, 0)=X"RTN", "DGPTAEE1" ,78,0) S X =$E(REC,1, 4)_"  "_$E (REC,5,14) _SP_$E(REC ,15,16)_SP _$E(REC,17 ,18)_SP_$E (REC,19,20 )_SP_$E(RE C,21,24)_S P_$E(REC,3 1,32)_SP_$ E(REC,33,3 4)_SP_$E(R EC,35,36)_ SP_$E(REC, 37,40)_SP" RTN","DGPT AEE1",79,0 ) S X=X_"   "_$E(REC, 41,46)_"   "_$E(REC,4 7,48)_"  " _$E(REC,49 ,51)_"  "_ $E(REC,52, 54)_"  "_$ E(REC,55)" RTN","DGPT AEE1",80,0 ) S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E1",81,0)  S X="",$P( X," ",80)= " " F X1=1 :1 S I=$P( DGER,",",X 1) Q:I=""   I $P(I,": ")<10 S X2 =+$P(I,":" ,2),X=$E(X ,1,X2-1)_" #"_$E(X,X2 +1,80)"RTN ","DGPTAEE 1",82,0) S  VALMCNT=V ALMCNT+1,^ TMP("AD",$ J,VALMCNT, 0)=X"RTN", "DGPTAEE1" ,83,0) I D GPTLINE=1  D  ;icd9 l ayout. ft   12/2/14"R TN","DGPTA EE1",84,0)  .S X="--- --------DI AGNOSTIC C ODES------ ------""RT N","DGPTAE E1",85,0)  .S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X"RTN ","DGPTAEE 1",86,0) . S X=$E(REC ,56,62)_SP _$E(REC,63 ,69)_SP_$E (REC,70,76 )_SP_$E(RE C,77,83)_S P_$E(REC,8 4,90)"RTN" ,"DGPTAEE1 ",87,0) .S  VALMCNT=V ALMCNT+1,^ TMP("AD",$ J,VALMCNT, 0)=X"RTN", "DGPTAEE1" ,88,0) .S  X="",$P(X, " ",80)="  " F X1=1:1  S I=$P(DG ER,",",X1)  Q:I=""  I  $P(I,":") =10 S X2=+ $P(I,":",2 ),X=$E(X,1 ,X2-1)_"#" _$E(X,X2+1 ,80)"RTN", "DGPTAEE1" ,89,0) .S  VALMCNT=VA LMCNT+1,^T MP("AD",$J ,VALMCNT,0 )=X"RTN"," DGPTAEE1", 90,0) .S X ="SSN ATTY  PHY PHY L OC  CDE BS I LI SI DR UG A4 A5    SC AO IR  SWAC""RTN" ,"DGPTAEE1 ",91,0) .S  VALMCNT=V ALMCNT+1,^ TMP("AD",$ J,VALMCNT, 0)=X"RTN", "DGPTAEE1" ,92,0) .S  X=$E(REC,9 1,99)_"     "_$E(REC, 100,105)_"     "_$E(R EC,106,107 )_"  "_$E( REC,108)_"    "_$E(RE C,109)_"   "_$E(REC,1 10)_SP_$E( REC,111,11 4)_"  "_$E (REC,115)_ SP_$E(REC, 116,119)_"   "_$E(REC ,120)_"  " _$E(REC,12 1)_"  "_$E (REC,122)_ "  "_$E(RE C,123)"RTN ","DGPTAEE 1",93,0) . S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",94,0) .S  X="",$P(X ," ",80)="  " F X1=1: 1 S I=$P(D GER,",",X1 ) Q:I=""   I $P(I,":" )>10 S X2= +$P(I,":", 2),X=$E(X, 1,X2-1)_"# "_$E(X,X2+ 1,80)"RTN" ,"DGPTAEE1 ",95,0) .S  VALMCNT=V ALMCNT+1,^ TMP("AD",$ J,VALMCNT, 0)=X"RTN", "DGPTAEE1" ,96,0) I D GPTLINE=2  D  ;icd10  layout. ft   12/2/14" RTN","DGPT AEE1",97,0 ) .S X="-- ---------D IAGNOSTIC  CODES----- -------""R TN","DGPTA EE1",98,0)  .S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E1",99,0)  .S X=$E(RE C,56,63)_S P_$E(REC,6 4,71)_SP_$ E(REC,72,7 9)_SP_$E(R EC,80,87)_ SP_$E(REC, 88,95)"RTN ","DGPTAEE 1",100,0)  .S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X"RTN ","DGPTAEE 1",101,0)  .S X=$E(RE C,96,103)_ SP_$E(REC, 104,111)_S P_$E(REC,1 12,119)_SP _$E(REC,12 0,127)_SP_ $E(REC,128 ,135)"RTN" ,"DGPTAEE1 ",102,0) . S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",103,0) . S X=$E(REC ,136,143)_ SP_$E(REC, 144,151)_S P_$E(REC,1 52,159)_SP _$E(REC,16 0,167)_SP_ $E(REC,168 ,175)"RTN" ,"DGPTAEE1 ",104,0) . S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",105,0) . S X=$E(REC ,176,183)_ SP_$E(REC, 184,191)_S P_$E(REC,1 92,199)_SP _$E(REC,20 0,207)_SP_ $E(REC,208 ,215)"RTN" ,"DGPTAEE1 ",106,0) . S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE1 ",107,0) . S X=$E(REC ,216,223)_ SP_$E(REC, 224,231)_S P_$E(REC,2 32,239)_SP _$E(REC,24 0,247)_SP_ $E(REC,248 ,255)_SP_$ E(REC,265, 270)_SP_$E (REC,271,2 72)_SP_$E( REC,273)"R TN","DGPTA EE1",108,0 ) .S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE1",109,0 ) .S X="", $P(X," ",8 0)=" " F X 1=1:1 S I= $P(DGER,", ",X1) Q:I= ""  I $P(I ,":")>9 S  X2=+$P(I," :",2),X=$E (X,1,X2-1) _"#"_$E(X, X2+1,80)"R TN","DGPTA EE1",110,0 ) .S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE1",111,0 ) D WRER^D GPTAEE"RTN ","DGPTAEE 1",112,0)  Q"RTN","DG PTAEE1",11 3,0) ;"RTN ","DGPTAEE 2")0^68^B3 3399825"RT N","DGPTAE E2",1,0)DG PTAEE2 ;AL B/MTC,HIOF O/FT - Aus tin Edits  EAL Report  Continued  ;12/17/14  11:09am"R TN","DGPTA EE2",2,0)  ;;5.3;Regi stration;* *8,338,415 ,565,729,6 64,884,914 **;Aug 13,  1993;Buil d 104"RTN" ,"DGPTAEE2 ",3,0) ;"R TN","DGPTA EE2",4,0)  ;no extern al referen ces"RTN"," DGPTAEE2", 5,0) ;"RTN ","DGPTAEE 2",6,0) ;D GPTLINE=1  is icd9 la yout"RTN", "DGPTAEE2" ,7,0) ;DGP TLINE=2 is  icd10 lay out"RTN"," DGPTAEE2", 8,0)H601(R EC) ;-- 60 1 error pr ocessing"R TN","DGPTA EE2",9,0)  ; INPUT :  REC - Reco rd that co ntains the  errors"RT N","DGPTAE E2",10,0)  N X,X1"RTN ","DGPTAEE 2",11,0) S  X="PROC      SSN      ADM-DATE- TIME PROC- DATE-TIME  SPC  TYPE  TRT""RTN", "DGPTAEE2" ,12,0) S V ALMCNT=VAL MCNT+1,^TM P("AD",$J, VALMCNT,0) =X"RTN","D GPTAEE2",1 3,0) S X=$ E(REC,1,4) _"  "_$E(R EC,5,14)_S P_$E(REC,1 5,16)_SP_$ E(REC,17,1 8)_SP_$E(R EC,19,20)_ SP_$E(REC, 21,24)_SP_ $E(REC,31, 32)_SP_$E( REC,33,34) _SP_$E(REC ,35,36)_SP _$E(REC,37 ,40)_"  "" RTN","DGPT AEE2",14,0 ) S X=X_$E (REC,41,42 )_"     "_ $E(REC,43) _"  "_$E(R EC,44,46)" RTN","DGPT AEE2",15,0 ) S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E2",16,0)  S X="----- ------PROC EDURE CODE S--------- ----""RTN" ,"DGPTAEE2 ",17,0) S  VALMCNT=VA LMCNT+1,^T MP("AD",$J ,VALMCNT,0 )=X"RTN"," DGPTAEE2", 18,0) I DG PTLINE=1 D   ;icd9 la yout. ft   12/2/14"RT N","DGPTAE E2",19,0)  .S X=$E(RE C,47,53)_S P_$E(REC,5 4,60)_SP_$ E(REC,61,6 7)_SP_$E(R EC,68,74)_ SP_$E(REC, 75,81)"RTN ","DGPTAEE 2",20,0) . S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE2 ",21,0) I  DGPTLINE=2  D  ;icd10  layout. f t  11/19/1 4"RTN","DG PTAEE2",22 ,0) .S X=$ E(REC,47,5 3)_SP_$E(R EC,55,61)_ SP_$E(REC, 63,69)_SP_ $E(REC,71, 77)_SP_$E( REC,79,85) "RTN","DGP TAEE2",23, 0) .S VALM CNT=VALMCN T+1,^TMP(" AD",$J,VAL MCNT,0)=X" RTN","DGPT AEE2",24,0 ) .S X=$E( REC,87,93) _SP_$E(REC ,95,101)_S P_$E(REC,1 03,109)_SP _$E(REC,11 1,117)_SP_ $E(REC,119 ,125)"RTN" ,"DGPTAEE2 ",25,0) .S  VALMCNT=V ALMCNT+1,^ TMP("AD",$ J,VALMCNT, 0)=X"RTN", "DGPTAEE2" ,26,0) .S  X=$E(REC,1 27,133)_SP _$E(REC,13 5,141)_SP_ $E(REC,143 ,149)_SP_$ E(REC,151, 157)_SP_$E (REC,159,1 65)"RTN"," DGPTAEE2", 27,0) .S V ALMCNT=VAL MCNT+1,^TM P("AD",$J, VALMCNT,0) =X"RTN","D GPTAEE2",2 8,0) .S X= $E(REC,167 ,173)_SP_$ E(REC,175, 181)_SP_$E (REC,183,1 89)_SP_$E( REC,191,19 7)_SP_$E(R EC,199,205 )"RTN","DG PTAEE2",29 ,0) .S VAL MCNT=VALMC NT+1,^TMP( "AD",$J,VA LMCNT,0)=X "RTN","DGP TAEE2",30, 0) .S X=$E (REC,207,2 13)_SP_$E( REC,215,22 1)_SP_$E(R EC,223,229 )_SP_$E(RE C,231,237) _SP_$E(REC ,239,245)" RTN","DGPT AEE2",31,0 ) .S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE2",32,0)  D WRER^DG PTAEE"RTN" ,"DGPTAEE2 ",33,0) Q" RTN","DGPT AEE2",34,0 ) ;"RTN"," DGPTAEE2", 35,0)H701( REC) ;-- 7 01 header" RTN","DGPT AEE2",36,0 ) ; INPUT  : REC - Re cord that  contains t he errors" RTN","DGPT AEE2",37,0 ) N X,X1,X 2"RTN","DG PTAEE2",38 ,0) S X="D ISP   SSN        ADM- DATE-TIME  DIS-DATE-T IME SPC  T YPE OP/RX  VA/AUS PLA CE RECVNG" "RTN","DGP TAEE2",39, 0) S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE2",40,0)  S X=$E(RE C,1,4)_"   "_$E(REC,5 ,14)_SP_$E (REC,15,16 )_SP_$E(RE C,17,18)_S P_$E(REC,1 9,20)_SP_$ E(REC,21,2 4)_SP_$E(R EC,31,32)_ SP_$E(REC, 33,34)_SP_ $E(REC,35, 36)_SP_$E( REC,37,40) _SP"RTN"," DGPTAEE2", 41,0) S X= X_$E(REC,4 1,42)_"     "_$E(REC, 43)_"      "_$E(REC,4 4)_"     " _$E(REC,45 )_"      " _$E(REC,46 )_"   "_$E (REC,47,52 )"RTN","DG PTAEE2",42 ,0) S VALM CNT=VALMCN T+1,^TMP(" AD",$J,VAL MCNT,0)=X" RTN","DGPT AEE2",43,0 ) S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" "  I $P(I, ":")<11 S  X2=+$P(I," :",2),X=$E (X,1,X2-1) _"#"_$E(X, X2+1,80)"R TN","DGPTA EE2",44,0)  S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X"RTN ","DGPTAEE 2",45,0) I  DGPTLINE= 1 D"RTN"," DGPTAEE2", 46,0) .S X ="ASIH XXX X C/P  DXL S   ODX  M PCR CODE    PHY LOC   %SC LI SI  DRUG A4 A5 ""RTN","DG PTAEE2",47 ,0) .S VAL MCNT=VALMC NT+1,^TMP( "AD",$J,VA LMCNT,0)=X "RTN","DGP TAEE2",48, 0) .S X=$E (REC,53,55 )_"    "_$ E(REC,56)_ "   "_$E(R EC,57)_"    "_$E(REC, 58,64)_"   "_$E(REC,6 5)_"  "_$E (REC,66,71 )_"        "_$E(REC,7 2,73)_"      "_$E(REC ,74,76)_"   "_$E(REC, 77)_"  "_$ E(REC,78)_ SP_$E(REC, 79,82)_"   "_$E(REC,8 3)_SP_$E(R EC,84,87)" RTN","DGPT AEE2",49,0 ) .S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE2",50,0)  .S X="",$ P(X," ",80 )=" " F X1 =1:1 S I=$ P(DGER,"," ,X1) Q:I=" "  I $P(I, ":")>10 S  X2=+$P(I," :",2),X=$E (X,1,X2-1) _"#"_$E(X, X2+1,80)"R TN","DGPTA EE2",51,0)  .S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E2",52,0)  I DGPTLINE =2 D"RTN", "DGPTAEE2" ,53,0) .S  X="ASIH RA CE C/P  DX LS   ODX   MPCR CODE    PHY LOC   %SC LI SI  DRUG A4 A 5""RTN","D GPTAEE2",5 4,0) .S VA LMCNT=VALM CNT+1,^TMP ("AD",$J,V ALMCNT,0)= X"RTN","DG PTAEE2",55 ,0) .S X=$ E(REC,53,5 5)_"    "_ $E(REC,56) _"   "_$E( REC,57)_"    "_$E(REC ,58,65)_"   "_$E(REC, 66)_"  "_$ E(REC,67,7 2)_"        "_$E(REC, 73,74)_"      "_$E(RE C,75,77)_"   "_$E(REC ,78)_"  "_ $E(REC,79) _SP_$E(REC ,80,83)_"   "_$E(REC, 84)_SP_$E( REC,85,88) "RTN","DGP TAEE2",56, 0) .S VALM CNT=VALMCN T+1,^TMP(" AD",$J,VAL MCNT,0)=X" RTN","DGPT AEE2",57,0 ) .S X="", $P(X," ",8 0)=" " F X 1=1:1 S I= $P(DGER,", ",X1) Q:I= ""  I $P(I ,":")>10,$ P(I,":")<2 4 S X2=+$P (I,":",2), X=$E(X,1,X 2-1)_"#"_$ E(X,X2+1,8 0)"RTN","D GPTAEE2",5 8,0) .S VA LMCNT=VALM CNT+1,^TMP ("AD",$J,V ALMCNT,0)= X"RTN","DG PTAEE2",59 ,0) .;Camp  Lejeune P WC - RSD 2 .6.5.7 PTF  Close out  Screen DG *5.3*914"R TN","DGPTA EE2",60,0)  .S X="SC  AO IR SWAC  MST HNC E TH RACE          CV S HAD     CL ""RTN","DG PTAEE2",61 ,0) .S VAL MCNT=VALMC NT+1,^TMP( "AD",$J,VA LMCNT,0)=X "RTN","DGP TAEE2",62, 0) .;Camp  Lejeune PW C - RSD 2. 6.5.7 PTF  Close out  Screen DG* 5.3*914 se t to piece  113 to ma tch ICD9 l ayout and  114 to mat ch ICD10"R TN","DGPTA EE2",63,0)  .S X=$E(R EC,89)_"   "_$E(REC,9 0)_"  "_$E (REC,91)_"   "_$E(REC ,92)_"      "_$E(REC, 93)_"   "_ $E(REC,94) _"  "_$E(R EC,95,96)_ "  "_$E(RE C,99,108)_ "  "_$E(RE C,109)_"   "_$E(REC,1 10)_"           "_$S( DGPTLINE=1 :$E(REC,11 3),1:$E(RE C,114))"RT N","DGPTAE E2",64,0)  .S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X"RTN ","DGPTAEE 2",65,0) D  WRER^DGPT AEE"RTN"," DGPTAEE2", 66,0) Q"RT N","DGPTAE E2",67,0)  ;"RTN","DG PTAEE2",68 ,0)H702(RE C) ;-- 702  header"RT N","DGPTAE E2",69,0)  ; INPUT :  REC - Reco rd that co ntains the  errors"RT N","DGPTAE E2",70,0)  N X,X1"RTN ","DGPTAEE 2",71,0) S  X="ADM     SSN        ADM-DATE- TIME DIS-D ATE-TIME"" RTN","DGPT AEE2",72,0 ) S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E2",73,0)  S X=$E(REC ,1,4)_"  " _$E(REC,5, 14)_SP_$E( REC,15,16) _SP_$E(REC ,17,18)_SP _$E(REC,19 ,20)_SP_$E (REC,21,24 )_SP_$E(RE C,31,32)_S P_$E(REC,3 3,34)_SP_$ E(REC,35,3 6)_SP_$E(R EC,37,40)" RTN","DGPT AEE2",74,0 ) S VALMCN T=VALMCNT+ 1,^TMP("AD ",$J,VALMC NT,0)=X"RT N","DGPTAE E2",75,0)  S X="----- ---------- ---------- ---DIAGNOS TIC CODES- ---------- ---------- -------""R TN","DGPTA EE2",76,0)  S VALMCNT =VALMCNT+1 ,^TMP("AD" ,$J,VALMCN T,0)=X"RTN ","DGPTAEE 2",77,0) I  DGPTLINE= 1 D  ;icd9  layout. f t  11/19/1 4"RTN","DG PTAEE2",78 ,0) .S X=$ E(REC,41,4 7)_SP_$E(R EC,48,54)_ SP_$E(REC, 55,61)_SP_ $E(REC,62, 68)_SP_$E( REC,69,75) _SP_$E(REC ,76,82)_SP _$E(REC,83 ,89)_SP_$E (REC,90,96 )_SP_$E(RE C,97,103)" RTN","DGPT AEE2",79,0 ) .S VALMC NT=VALMCNT +1,^TMP("A D",$J,VALM CNT,0)=X"R TN","DGPTA EE2",80,0)  I DGPTLIN E=2 D  ;ic d10 layout . ft  11/1 9/14"RTN", "DGPTAEE2" ,81,0) .S  X=$E(REC,4 1,48)_SP_$ E(REC,49,5 6)_SP_$E(R EC,57,64)_ SP_$E(REC, 65,72)_SP_ $E(REC,73, 80)"RTN"," DGPTAEE2", 82,0) .S V ALMCNT=VAL MCNT+1,^TM P("AD",$J, VALMCNT,0) =X"RTN","D GPTAEE2",8 3,0) .S X= $E(REC,81, 88)_SP_$E( REC,89,96) _SP_$E(REC ,97,104)_S P_$E(REC,1 05,112)_SP _$E(REC,11 3,120)"RTN ","DGPTAEE 2",84,0) . S VALMCNT= VALMCNT+1, ^TMP("AD", $J,VALMCNT ,0)=X"RTN" ,"DGPTAEE2 ",85,0) .S  X=$E(REC, 121,128)_S P_$E(REC,1 29,136)_SP _$E(REC,13 7,144)_SP_ $E(REC,145 ,152)_SP_$ E(REC,153, 160)"RTN", "DGPTAEE2" ,86,0) .S  VALMCNT=VA LMCNT+1,^T MP("AD",$J ,VALMCNT,0 )=X"RTN"," DGPTAEE2", 87,0) .S X =$E(REC,16 1,168)_SP_ $E(REC,169 ,176)_SP_$ E(REC,177, 184)_SP_$E (REC,185,1 92)_SP_$E( REC,193,20 0)"RTN","D GPTAEE2",8 8,0) .S VA LMCNT=VALM CNT+1,^TMP ("AD",$J,V ALMCNT,0)= X"RTN","DG PTAEE2",89 ,0) .S X=$ E(REC,201, 208)_SP_$E (REC,209,2 16)_SP_$E( REC,217,22 4)_SP_$E(R EC,225,232 )"RTN","DG PTAEE2",90 ,0) .S VAL MCNT=VALMC NT+1,^TMP( "AD",$J,VA LMCNT,0)=X "RTN","DGP TAEE2",91, 0) D WRER^ DGPTAEE"RT N","DGPTAE E2",92,0)  Q"RTN","DG PTAEE2",93 ,0) ;"RTN" ,"DGPTF")0 ^16^B24892 539"RTN"," DGPTF",1,0 )DGPTF ;AL B/JDS,AS -  PTF LOAD/ EDIT DRIVE R ;5/17/05  12:13pm"R TN","DGPTF ",2,0) ;;5 .3;Registr ation;**26 ,58,164,19 5,397,565, 664,850,91 4**;Aug 13 , 1993;Bui ld 104"RTN ","DGPTF", 3,0) ;"RTN ","DGPTF", 4,0) D LO^ DGUTL"RTN" ,"DGPTF",5 ,0) I $D(^ DISV(DUZ," ^DPT(")),$ D(^("^DGPT (")) S A=+ ^("^DGPT(" ),B=+^("^D PT(") I $D (^DGPT(A,0 )),$D(^DPT (B,0)) S:( +^DGPT(A,0 )'=B&$D(^D GPT("B",B) )) ^DISV(D UZ,"^DGPT( ")="""RTN" ,"DGPTF",6 ,0) ;"RTN" ,"DGPTF",7 ,0)ASK W ! ! K DIC S  DIC="^DGPT (",DIC(0)= "EQMZA",DG PR=0,DIC(" S")="I '$P (^DGPT(+Y, 0),U,6)!($ P(^(0),U,6 )=1),$P(^( 0),U,11)=1 ""RTN","DG PTF",8,0)  ;DG*5.3*86 1 Added DG RELKEY var iable to h old the va lue for DG REL that i s killed i n ^EASECU2 1"RTN","DG PTF",9,0)  N DGRELKEY  D ^DIC G  Q1:Y'>0 S  PTF=+Y,(DG RELKEY,DGR EL)=$S($D( ^XUSEC("DG  PTFREL",D UZ)):1,1:0 )"RTN","DG PTF",10,0)  I '$D(^DG PT(PTF,"M" ,0))#2 S ^ (0)="^45.0 2^^""RTN", "DGPTF",11 ,0) K DIC  S DFN=+Y(0 ),DGADM=+$ P(Y(0),U,2 ),^DISV(DU Z,"^DPT(") =DFN,DGST= +$P(Y(0),U ,6)"RTN"," DGPTF",12, 0) N DGPMC A,DGPMAN D  PM^DGPTUT L"RTN","DG PTF",13,0)  D:DGST=0  MT^DGPTUTL ,INCOME^DG PTUTL1"RTN ","DGPTF", 14,0) I DG ST I 'DGRE L!($D(DGQW K))!(DGST> 1) W:$X>60  "   ???-- Already ", $S(DGST=1: "Closed",D GST=2:"Rel eased",1:" Transmitte d") G ASK" RTN","DGPT F",15,0) ; "RTN","DGP TF",16,0)E N1 ;"RTN", "DGPTF",17 ,0) K DGPT FE S DGPTF E=$P(^DGPT (PTF,0),"^ ",4)"RTN", "DGPTF",18 ,0) I 'DGP TFE,'DGST  G UP:$P(DG PMAN,"^",1 6)'=PTF D: '$P(^DGPT( PTF,0),"^" ,5) SUF D  LE^DGPTTS, DC"RTN","D GPTF",19,0 ) I $D(DGQ WK) D ^DGP TFQWK,Q1 S  DGQWK=1 G  DGPTF"RTN ","DGPTF", 20,0) ;"RT N","DGPTF" ,21,0)GETD  ;"RTN","D GPTF",22,0 ) K A"RTN" ,"DGPTF",2 3,0) I $P( ^DGPT(PTF, 0),U,11)=1  D CEN^DGP TC1"RTN"," DGPTF",24, 0) ; pwc D G*5.3*914  RSD SPEC#  2.6.5.2.1  101 Screen  Camp Leje une added" RTN","DGPT F",25,0) F  I=0,.521, .11,.52,.3 21,.32,.32 17,57,.3 S  A(I)="" S :$D(^DPT(D FN,I))&('D GST) A(I)= ^(I) I DGS T S:$D(^DG P(45.84,PT F,$S('I:10 ,1:I))) A( I)=^($S('I :10,1:I))" RTN","DGPT F",26,0) S  A("MST")= $P($$GETST AT^DGMSTAP I(DFN),U,2 ,5)"RTN"," DGPTF",27, 0) K DGNTA RR N CLV    ;pwc DG*5 .3*914 RSD  SPEC# 2.6 .5.2.1 101  Screen Ca mp Lejeune "RTN","DGP TF",28,0)  S A("NTR") =$S($$GETC UR^DGNTAPI (DFN,"DGNT ARR")>0:DG NTARR("INT RP"),1:"") "RTN","DGP TF",29,0)  K DGNTARR" RTN","DGPT F",30,0) K  B F I=0,1 01,70 S B( I)="" S:$D (^DGPT(PTF ,I)) B(I)= ^(I)"RTN", "DGPTF",31 ,0) S A("C V")=$$CVED T^DGCV(DFN ,$P($G(B(0 )),U,2))"R TN","DGPTF ",32,0) S  A("SHAD")= $$GETSHAD^ DGUTL3(DFN )"RTN","DG PTF",33,0)  ; pwc DG* 5.3*914 RS D SPEC# 2. 6.5.2.1 10 1 Screen C amp Lejeun e"RTN","DG PTF",34,0)  S A("CLV" )=$S($$GET CL^DGUTL3( DFN)=1:"Y" ,$$GETCL^D GUTL3(DFN) =0:"N",1:" ")"RTN","D GPTF",35,0 ) S CLV=$P ($G(^DGPT( PTF,70))," ^",33)  ;g et 'Treate d for Camp  Lejeune'  from PTF f ile (#45)" RTN","DGPT F",36,0) S  DGDD=+B(7 0),DGFC=+$ P(B(0),U,3 )"RTN","DG PTF",37,0)  S Y=DGDD  D FMT^DGPT UTL"RTN"," DGPTF",38, 0) S Y=DGA DM D D^DGP TUTL S DGA D=Y,HEAD=" Name: "_$P (A(0),U,1) _"  SSN: " _$P(A(0),U ,9)_" Dt o f Adm: "_D GAD"RTN"," DGPTF",39, 0) S DGN=$ S(DGST!DGP R:1,1:0)"R TN","DGPTF ",40,0) I  DGPR S (DG ST,DGPTFE) =1 G FAC^D GPTF1"RTN" ,"DGPTF",4 1,0) I DGP TFE,'DGST  K DR S DIE ="^DGPT(", DA=PTF,DR= "2" D ^DIE  K DR G Q: $D(Y) S DG ADM=$P(^DG PT(PTF,0), U,2),^DISV (DUZ,"PTFA D",DFN)=DG ADM,Y=DGAD M D D^DGPT UTL S HEAD =$P(HEAD,D GAD,1)_Y"R TN","DGPTF ",42,0) G  ^DGPTF1"RT N","DGPTF" ,43,0) ;"R TN","DGPTF ",44,0)Q I  '$P(^DGPT (PTF,0),"^ ",4),'$P(^ (0),U,6) W  !,"  Upda ting TRANS FER DRGs"  S DGADM=$P (^DGPT(PTF ,0),U,2) D  SUDO1^DGP TSUDO"RTN" ,"DGPTF",4 5,0) D Q1" RTN","DGPT F",46,0) I  $D(DGADPR )!($D(DGPT OUT)) K DG PTOUT Q"RT N","DGPTF" ,47,0) G D GPTF"RTN", "DGPTF",48 ,0) ;"RTN" ,"DGPTF",4 9,0)Q1 ; - - housekee ping"RTN", "DGPTF",50 ,0) I $D(I OM) S X=IO M X ^%ZOSF ("RM")"RTN ","DGPTF", 51,0) D KV AR^DGPTUTL 1,KVAR^DGP TC1 K SDCL Y"RTN","DG PTF",52,0)  Q"RTN","D GPTF",53,0 ) ;"RTN"," DGPTF",54, 0)SUF I $D (^DIC(42,+ $P(DGPMAN, U,6),0)) S  DGX=$P(^( 0),U,3) D" RTN","DGPT F",55,0) . S DGX=$S(D GX="":"",D GX="D":"D  NUMACT^DGP TSUF(30)", DGX="NH":" D NUMACT^D GPTSUF(40) ",1:"")"RT N","DGPTF" ,56,0) .Q: DGX="""RTN ","DGPTF", 57,0) .X D GX Q:DGANU M'=1"RTN", "DGPTF",58 ,0) .N DGF DA,DGMSG"R TN","DGPTF ",59,0) .S  DGFDA(45, PTF_",",5) =DGSUFNAM( DGANUM)"RT N","DGPTF" ,60,0) .D  FILE^DIE(" ","DGFDA", "DGMSG")"R TN","DGPTF ",61,0) K  DGANUM,DGS UFNAM,DGX" RTN","DGPT F",62,0) Q "RTN","DGP TF",63,0)O RDER ; --  order mvt  ; I1 := #m vts+1 ; M( ) := mvt a rray"RTN", "DGPTF",64 ,0) N DGRT  S DGRT=$S (I1<25:"MT ",1:"^UTIL ITY(""DGPT MT"",$J)")  K @DGRT"R TN","DGPTF ",65,0) N  DGRT82 S D GRT82=$S(I 1<25:"MT82 ",1:"^UTIL ITY(""DGPT MT82"",$J) ") K @DGRT 82"RTN","D GPTF",66,0 ) F I=0:0  S I=$O(M(I )) Q:'I  D "RTN","DGP TF",67,0)  . S NU=+$P (M(I),U,10 ),NU=$S('N U:9999999+ I,1:NU)"RT N","DGPTF" ,68,0) . S  NU=$S($D( @DGRT@(NU) ):NU+(I*.1 ),1:NU) S  @DGRT@(NU, I)=M(I),@D GRT82@(NU, I)=$G(M(I, 82))"RTN", "DGPTF",69 ,0) S K=0  F I=0:0 S  I=$O(@DGRT @(I)) Q:'I   D"RTN"," DGPTF",70, 0) . S K=K +1,J=$O(@D GRT@(I,0))  S M(K)=@D GRT@(I,J), M(K,82)=@D GRT82@(I,J )"RTN","DG PTF",71,0)  K @DGRT Q "RTN","DGP TF",72,0)  ;"RTN","DG PTF",73,0) ADM S DFN= +^DGPT(DA, 0),%=$O(^( "M","AM",0 )) I %<X&( %>0) K X W  !,"Not af ter first  movement"" RTN","DGPT F",74,0) Q :'$D(X)  I  $D(^DGPT( "AAD",DFN, X))&($P(^D GPT(DA,0), U,2)'=X) K  X W !,"Th ere is alr eady a PTF  entry at  that time" "RTN","DGP TF",75,0)  Q"RTN","DG PTF",76,0)  ;"RTN","D GPTF",77,0 )WR ;Calle d from ^DD (45,0,"ID" ,"WR")"RTN ","DGPTF", 78,0) Q:'$ D(^DGPT(+$ G(Y),0))   S DGNODE=^ (0),DGADM= $P(DGNODE, U,2) W "   Admitted:  ",$TR($$FM TE^XLFDT(D GADM,"5DF" )," ","0") ," ""RTN", "DGPTF",79 ,0) ; uses  new FMTE  parameter  for XLFDT,  Y2K in li ne WR"RTN" ,"DGPTF",8 0,0) ;"RTN ","DGPTF", 81,0) F DG Z=6,4 S %= ";"_$S($D( ^DD(45,DGZ ,0)):$P(^( 0),U,3),1: "") W $P($ P(%,";"_$P (DGNODE,U, DGZ)_":",2 ),";",1)_"  ""RTN","D GPTF",82,0 ) K DGNODE ,DGZ Q"RTN ","DGPTF", 83,0) ;"RT N","DGPTF" ,84,0)DC S  DGPDN=$S( $D(^DGPM(+ $P(DGPMAN, "^",17),0) ):^(0),1:" ")"RTN","D GPTF",85,0 ) S DGDC=+ DGPDN,DG72 =$S($D(^DG (405.2,+$P (DGPDN,"^" ,18),0)):$ P(^(0),"^" ,8),1:0),D GTY=$S(DGD C:1,1:"")" RTN","DGPT F",86,0) I  DGDC F I= 0:0 S I=$O (^DGPM("AP MV",DFN,DG PMCA,I)) Q :I'>0  I $ D(^DGPM(+$ O(^(I,0)), 0)),$P(^(0 ),"^",2)=2  S J=U_$P( ^(0),"^",1 8)_U,DGTY= $S("^43^44 ^13^45^"[J :4,"^1^"[J :2,"^2^3^" [J:3,1:1)  Q"RTN","DG PTF",87,0)  S X=$S($D (^DGPT(PTF ,70)):^(70 ),1:"")"RT N","DGPTF" ,88,0) S D R="70///"_ $S(DGDC:"/ "_DGDC,'X: "",1:"@")_ $S(DG72:"; 72////"_DG 72,1:"")_" ;72.1///"_ $S(DGTY:"/ "_DGTY,'$P (X,"^",14) :"",1:"@") ,DIE="^DGP T(",DA=PTF  D ^DIE"RT N","DGPTF" ,89,0) I D GDC>DT,$P( DGPDN,"^", 18)=42 W:' $D(ZTQUEUE D) !,"Disc harge 'Whi le ASIH' i s in the f uture.""RT N","DGPTF" ,90,0) K D G72,DGTY,D GPDN Q"RTN ","DGPTF", 91,0) ;"RT N","DGPTF" ,92,0)UP S  DIE="^DGP T(",DR="4/ //F",DA=PT F D ^DIE W  !,"Pointe r from Pat ient file  is incorre ct. Record  changed t o Fee Basi s",! S DGP TFE=1 G GE TD"RTN","D GPTF1")0^1 7^B4323609 2"RTN","DG PTF1",1,0) DGPTF1 ;AL B/JDS/PLT  - PTF ENTR Y/EDIT ; 0 8 Dec 2017   8:08 AM" RTN","DGPT F1",2,0) ; ;5.3;Regis tration;** 69,114,195 ,397,342,4 15,565,664 ,884,914** ;Aug 13, 1 993;Build  104"RTN"," DGPTF1",3, 0) ;;Per V A Directiv e 6402, th is routine  should no t be modif ied."RTN", "DGPTF1",4 ,0) ;"RTN" ,"DGPTF1", 5,0) I '$D (IOF) S IO P="HOME" D  ^%ZIS K I OP"RTN","D GPTF1",6,0 ) S:'$D(IO ST) IOST=" C" S DGVI= """""",DGV O=DGVI I $ D(IOST(0))  S:$D(^%ZI S(2,IOST(0 ),5)) I=^( 5) S:$L($P (I,U,4)) D GVI=$P(I,U ,4) S:$L($ P(I,U,5))  DGVO=$P(I, U,5) I $L( DGVI_DGVO) >4 S X=132  X ^%ZOSF( "RM")"RTN" ,"DGPTF1", 7,0)WR G G ET:'$D(A)! ('$D(B)) W  @IOF,HEAD ,?72,@DGVI ,"<101>",@ DGVO"RTN", "DGPTF1",8 ,0)FAC ; " RTN","DGPT F1",9,0) W  ! I $D(DG CST) S:$G( DGCN) X=$G (^DG(45.86 ,DGCN,0))  W ?37,"Cen sus " W:$G (DGCN) "Da te: ",$E(X ,4,5),"/", $E(X,6,7), "/",$E(X,2 ,3),"  " W  "Status:  ",$$EXTERN AL^DILFD(4 5,6,,+DGCS T)"RTN","D GPTF1",10, 0) W ! S Z =1 D Z W "    Facilit y: " S Z=$ P(B(0),U,3 )_$P(B(0), U,5),Z1=23  D Z1"RTN" ,"DGPTF1", 11,0)MAR S  Z=2 D Z W  " Marit S tat: ",$S( $D(^DIC(11 ,+$P(A(0), U,5),0)):$ P(^(0),U,1 ),1:"")"RT N","DGPTF1 ",12,0)SA  W !," Sour ce of Adm:  ",$S($D(^ DIC(45.1,+ B(101),0)) :$P(^(0),U ,5),1:"")" RTN","DGPT F1",13,0)  N VADM D D EM^VADPT"R TN","DGPTF 1",14,0) W  ?39,"Ethn ic: " D"RT N","DGPTF1 ",15,0) .I  'VADM(11)  W "" Q"RT N","DGPTF1 ",16,0) .N  NODE,NUM, ETHNIC,I"R TN","DGPTF 1",17,0) . S I=0"RTN" ,"DGPTF1", 18,0) .F N UM=0:1 S I =+$O(VADM( 11,I)) Q:' I  D"RTN", "DGPTF1",1 9,0) ..S X =$$PTR2COD E^DGUTL4(+ VADM(11,I) ,2,4)"RTN" ,"DGPTF1", 20,0) ..S  ETHNIC=$S( X="":"?",1 :X)"RTN"," DGPTF1",21 ,0) ..S X= $$PTR2CODE ^DGUTL4(+$ G(VADM(11, I,1)),3,4) "RTN","DGP TF1",22,0)  ..S ETHNI C=ETHNIC_$ S(X="":"?" ,1:X)"RTN" ,"DGPTF1", 23,0) ..I  NUM S ETHN IC=","_ETH NIC"RTN"," DGPTF1",24 ,0) ..W ET HNIC"RTN", "DGPTF1",2 5,0) W ?55 ,"Race: "  D"RTN","DG PTF1",26,0 ) .I 'VADM (12) W ""  Q"RTN","DG PTF1",27,0 ) .N NODE, NUM,RACE,I "RTN","DGP TF1",28,0)  .S I=0"RT N","DGPTF1 ",29,0) .F  NUM=0:1 S  I=+$O(VAD M(12,I)) Q :'I  D"RTN ","DGPTF1" ,30,0) ..S  X=$$PTR2C ODE^DGUTL4 (+VADM(12, I),1,4)"RT N","DGPTF1 ",31,0) .. S RACE=$S( X="":"?",1 :X)"RTN"," DGPTF1",32 ,0) ..S X= $$PTR2CODE ^DGUTL4(+$ G(VADM(12, I,1)),3,4) "RTN","DGP TF1",33,0)  ..S RACE= RACE_$S(X= "":"?",1:X )"RTN","DG PTF1",34,0 ) ..I NUM  S RACE="," _RACE"RTN" ,"DGPTF1", 35,0) ..W  RACE"RTN", "DGPTF1",3 6,0) K VAD M"RTN","DG PTF1",37,0 ) W !," So urce of Pa y: ",$$EXT ERNAL^DILF D(45,22,,$ P(B(101),U ,3))"RTN", "DGPTF1",3 8,0)SEX S  SEX=$P(A(0 ),U,2) W ? 39,"            Sex:  ",$S(SEX=" M":"MALE", SEX="F":"F EMALE",1:" ")"RTN","D GPTF1",39, 0) W !,"Tr ans Facili ty: ",$P(B (101),U,5) _$P(B(101) ,U,6)"RTN" ,"DGPTF1", 40,0)DOB S  DOB=$P(A( 0),U,3),Y= DOB D D^DG PTUTL W ?3 9," Date o f Birth: " ,Y"RTN","D GPTF1",41, 0)CAT I DG PTFMT<2 W  !,"    Cat  of Ben: " ,$S($D(^DI C(45.82,+$ P(B(101),U ,4),0)):$E ($P(^(0),U ,2),1,26), 1:"")"RTN" ,"DGPTF1", 42,0) W:$X >50 !"RTN" ,"DGPTF1", 43,0) W "     Admit E lig: "_$S( +$P(B(101) ,U,8):$P($ G(^DIC(8,+ $P(B(101), U,8),0)),U ),1:"UNKNO WN") W ?50 ,"SCI: ",$ $EXTERNAL^ DILFD(2,57 .4,,$P(A(5 7),U,4))"R TN","DGPTF 1",44,0)VI ET W ! S Z =3 D Z W " Vietnam SR V: " S L=$ P(A(.321), U,1),Z=$S( L="Y":"YES ",L="N":"N O",1:"UNKN OWN"),Z1=2 7 D Z1"RTN ","DGPTF1" ,45,0)ST S  Z=4 D Z W  $S('$$FOR IEN^DGADDU TL($P(A(.1 1),U,10))! ('$P(A(.11 ),U,10)):"   State: " _$S($D(^DI C(5,+$P(A( .11),U,5), 0)):$P(^(0 ),U,1),1:" "),1:"Coun try: "_$$C NTRYI^DGAD DUTL($P(A( .11),U,10) ))"RTN","D GPTF1",46, 0)POW W !? 11,"POW: "  S L=$P(A( .52),U,5)  W $S(L="Y" :"YES",L=" N":"NO",1: "UNKNOWN") "RTN","DGP TF1",47,0) ZIP W ?42, $S('$$FORI EN^DGADDUT L($P(A(.11 ),U,10))!( '$P(A(.11) ,U,10)):"    Zip Code : "_$P(A(. 11),U,6),1 :"Postal C ode: "_$P( A(.11),U,9 ))"RTN","D GPTF1",48, 0)POS W !, ?6," POW S RV: " S L= $P(A(.52), U,6) W $E( $S($D(^DIC (22,+L,0)) :$P(^(0),U ,1),1:""), 1,23)"RTN" ,"DGPTF1", 49,0)COU W  ?45,$S('$ $FORIEN^DG ADDUTL($P( A(.11),U,1 0))!('$P(A (.11),U,10 )):"  Coun ty: "_$S($ D(^DIC(5,+ $P(A(.11), U,5),1,+$P (A(.11),U, 7),0)):$P( ^(0),U,1), 1:""),1:"P rovince: " _$P(A(.11) ,U,8))"RTN ","DGPTF1" ,50,0)ION  W !,"   Io n Rad Exp:  " S L=$P( A(.321),U, 3) W $S(L= "Y":"YES", L="N":"NO" ,1:"UNKNOW N")"RTN"," DGPTF1",51 ,0)METH S  L=$P(A(.32 1),U,12) W :L'="" ?38 ,"Exposure  Method: " ,$S(L="N": "Nagasaki/ Hiroshima" ,L="T":"Nu clear Test ing",L="B" :"Both",1: "")"RTN"," DGPTF1",52 ,0)AO W !, "    AO Ex p/Loc: " S  L=$P(A(.3 21),U,2) W  $S(L="Y": "YES",L="N ":"NO",1:" UNKNOWN")" RTN","DGPT F1",53,0)  S L=$P(A(. 321),U,13)  W:L'="" $ S(L="V":"/ VIET",L="K ":"/DMZ",L ="O":"/OTH ER",1:"")" RTN","DGPT F1",54,0)S HAD W ?40, "PROJ 112/ SHAD: ",$S (A("SHAD") =1:"YES",1 :"NO")"RTN ","DGPTF1" ,55,0)MST  W !,"    C laims MST:  " S L=$P( A("MST"),U ) W $S(L=" Y":"YES",L ="N":"NO", L="D":"DEC LINED TO A NSWER",1:" UNKNOWN")  ; added 6/ 17/98 for  MST enhanc ement"RTN" ,"DGPTF1", 56,0)NTR W  ?39,"     N/T Radium : " S L=A( "NTR") W $ E($S(L'="" :L,1:"UNKN OWN"),1,25 )"RTN","DG PTF1",57,0 )CV S L=$S ($P(A("CV" ),U,1)>0:1 ,1:0)"RTN" ,"DGPTF1", 58,0) W !, "Combat Ve teran: ",$ S(L:"YES", 1:"NO")"RT N","DGPTF1 ",59,0) I  L S Y=$P(A ("CV"),U,2 ) D D^DGPT UTL W ?45, "End Date:  ",Y"RTN", "DGPTF1",6 0,0)CLV ;  pwc DG*5.3 *914 RSD S PEC# 2.6.6 .2.1 101 S creen Camp  Lejeune"R TN","DGPTF 1",61,0) ;  Camp Leje une will d isplay fro m file #40 5, but whe n edited,  it will fi le back bo th in PTF  file #45 a nd PATIENT  MOVEMENT  file #405" RTN","DGPT F1",62,0)  S CLV="" I  $G(DGPMCA )'="" S CL V=$P($G(^D GPM(DGPMCA ,"CLV"))," ^",1) ; CL V variable  is from P ATIENT MOV EMENT file  #405 (rec eived from  admission )"RTN","DG PTF1",63,0 ) S DGPTF1 =$D(^DGPM( "APTF",PTF ))"RTN","D GPTF1",64, 0) W:$P($G (^DGPT(PTF ,70)),U,33 )'="" ?38, "   Camp L ejeune: "_ $S($P($G(^ DGPT(PTF,7 0)),U,33)= "Y":"YES", 1:"NO")"RT N","DGPTF1 ",65,0) W: $P($G(^DGP T(PTF,70)) ,U,33)=""  ?38,"   Ca mp Lejeune : "_$S(CLV ="Y":"YES" ,1:"NO")"R TN","DGPTF 1",66,0) ; "RTN","DGP TF1",67,0)  D EN^DGPT F4 K A,B Q :DGPR"RTN" ,"DGPTF1", 68,0) ;"RT N","DGPTF1 ",69,0)JUM P F I=$Y:1 :20 W !"RT N","DGPTF1 ",70,0) G  101^DGPTFJ C:DGN S (D GZM0,DGZS0 )=0"RTN"," DGPTF1",71 ,0) R "Ent er:  <RET>  for <MAS> ,",!,"1-7  to edit,'^ N' for scr een N, or  '^' to abo rt: <MAS>/ / ",X:DTIM E S:'$T X= "^",DGPTOU T="""RTN", "DGPTF1",7 2,0) G ^DG PTFM:X="", Q:X="^""RT N","DGPTF1 ",73,0) I  X?1"^".E S  DGPTSCRN= 101 G ^DGP TFJ"RTN"," DGPTF1",74 ,0) G PR:X ?.N&($L(X) >2)"RTN"," DGPTF1",75 ,0) I X["- " S K=X,X= "" F I=1:1  S J=$P(K, ",",I) Q:J ']""  I +J <8 S:J'["- " X=X_J_", " I J["-"& (+J) I +J< +$P(J,"-", 2) F L=+J: 1:+$P(J,"- ",2) S:L<8  X=X_L_"," "RTN","DGP TF1",76,0)  I X'[",", 1234567'[X  G PR"RTN" ,"DGPTF1", 77,0) F I= 1:1 S J=$P (X,",",I)  Q:'J  G:J< 1!(J>7)!(J '?1N) PR"R TN","DGPTF 1",78,0) I  X<1!(X>7)  G PR"RTN" ,"DGPTF1", 79,0) S (P T(1),PT(2) )="",DGJUM P=X,DA=PTF ,DIE="^DGP T(",DR="[D G101"_$E(" F",DGPTFE) _"]" D ^DI E"RTN","DG PTF1",80,0 ) ;--"RTN" ,"DGPTF1", 81,0) N DG PMCA,DGPMA N D PM^DGP TUTL"RTN", "DGPTF1",8 2,0) I '$G (DGADM) S  DGADM=+^DG PT(PTF,0)" RTN","DGPT F1",83,0)  D MT^DGPTU TL"RTN","D GPTF1",84, 0) ; pwc D G*5.3*914  RSD SPEC#  2.6.6.2.1  101 Screen  Camp Leje une "RTN", "DGPTF1",8 5,0)GET F  I=.32,.52, 57,.521,0, .321,.3217 ,.11,.3 S  A(I)="" S: $D(^DPT(DF N,I))&('DG ST) A(I)=^ (I) I DGN  S:$D(^DGP( 45.84,PTF, $S('I:10,1 :I))) A(I) =^($S('I:1 0,1:I))"RT N","DGPTF1 ",86,0) ;  The follow ing line a dded for M ST enhance ment 4/21/ 99"RTN","D GPTF1",87, 0) S A("MS T")=$P($$G ETSTAT^DGM STAPI(DFN) ,U,2,5)"RT N","DGPTF1 ",88,0) K  DGNTARR N  CLV  ; pwc  DG*5.3*91 4 RSD SPEC # 2.6.5.2. 1 101 Scre en Camp Le jeune"RTN" ,"DGPTF1", 89,0) S A( "NTR")=$S( $$GETCUR^D GNTAPI(DFN ,"DGNTARR" )>0:DGNTAR R("INTRP") ,1:"")"RTN ","DGPTF1" ,90,0) K D GNTARR"RTN ","DGPTF1" ,91,0) F I =0,101,70  S B(I)=""  S:$D(^DGPT (PTF,I)) B (I)=^(I)"R TN","DGPTF 1",92,0) S  DGDD=+B(7 0),DGFC=+$ P(B(0),U,3 )"RTN","DG PTF1",93,0 ) S A("CV" )=$$CVEDT^ DGCV(DFN,$ P($G(B(0)) ,U,2))"RTN ","DGPTF1" ,94,0) S A ("SHAD")=$ $GETSHAD^D GUTL3(DFN) "RTN","DGP TF1",95,0)  ; pwc DG* 5.3*914 RS D SPEC# 2. 6.6.2.1 10 1 Screen C amp Lejeun e"RTN","DG PTF1",96,0 ) S A("CLV ")=$S($$GE TCL^DGUTL3 (DFN)=1:"Y ",$$GETCL^ DGUTL3(DFN )=0:"N",1: "")  ;gets  from PATI ENT file f or setting  Array"RTN ","DGPTF1" ,97,0) I $ G(DGPMCA)' ="" S CLV= $P($G(^DGP M(DGPMCA," CLV")),"^" ,1) ;get ' Treated fo r Camp Lej eune' from  PATIENT M OVEMENT fi le (#405)  to display  on 101 sc reen"RTN", "DGPTF1",9 8,0) K PT  G DGPTF1"R TN","DGPTF 1",99,0)PR  W !,"Ente r '^' to s top the di splay and  edit of da ta",!,"'^N ' to jump  to screen  #N (screen  # appears  in upper  right of s creen '<N> ')",!,"<RE T> to cont inue on to  the next  screen or  1-7 to edi t:""RTN"," DGPTF1",10 0,0) W !?1 0,"1-Facil ity, Sourc e of admis , Payment,  Transf fa cil, and C at. of Ben ef",!?10," 2-Marital  Stat, Race , Ethnicit y, Sex, SC I, DOB""RT N","DGPTF1 ",101,0) W  !?10,"3-A gent Orang e, Prisone r of War,  Ionizing R adiation,  MST, N/T R adium",!?1 2,"Camp Le jeune""RTN ","DGPTF1" ,102,0) W  !?10,"4-St ate, Count y, Zip cod e""RTN","D GPTF1",103 ,0) W !?10 ,"5-Discha rge date,  type & spe cialty",!? 10,"6-Outp atient tre at & VA Au spices",!? 10,"7-Rece iving Faci lity, ASIH  Days & C& P Status"" RTN","DGPT F1",104,0)  W !,"You  may also e nter any c ombination  of the ab ove, separ ated by co mmas(ex:1, 3,5)",!"RT N","DGPTF1 ",105,0) R  !!,"Enter  <RET> : " ,X:DTIME G  WR"RTN"," DGPTF1",10 6,0)Q G Q^ DGPTF"RTN" ,"DGPTF1", 107,0) Q"R TN","DGPTF 1",108,0)Z  I 'DGN S  Z=$S(IOST= "C-QUME"&( $L(DGVI)'= 2):Z,1:"[" _Z_"]") W  @DGVI,Z,@D GVO"RTN"," DGPTF1",10 9,0) E  W  "   ""RTN" ,"DGPTF1", 110,0) Q"R TN","DGPTF 1",111,0)Z 1 F I=1:1: (Z1-$L(Z))  S Z=Z_" " "RTN","DGP TF1",112,0 ) W Z"RTN" ,"DGPTF1", 113,0) Q"R TN","DGPTF CLV")0^71^ B5398483"R TN","DGPTF CLV",1,0)D GPTFCLV ;A LB/CLT - P TF CAMP LE JEUNE QUES TION;12/13 /2017 ; 04  Jan 2018   2:02 PM"R TN","DGPTF CLV",2,0)  ;;5.3;Regi stration;* *914**;Aug  13, 1993; Build 104" RTN","DGPT FCLV",3,0)  ;"RTN","D GPTFCLV",4 ,0) ; THIS  ROUTINE I S CALLED F ROM THE IN PUT TEMPLA TES DG101  and DG101F "RTN","DGP TFCLV",5,0 )PTF101 ;S ET THE CAM P LEJEUNE  FIELDS IN  PTF"RTN"," DGPTFCLV", 6,0) Q:$$G ETCL^DGUTL 3(DFN)'=1" RTN","DGPT FCLV",7,0)  N DGPTF,D GMV,DIR,DG B,X,Y"RTN" ,"DGPTFCLV ",8,0) S D GPTF=PTF,D GMV=DA S:D GMV=0 DGMV =1"RTN","D GPTFCLV",9 ,0) S DGMV =$O(^DGPM( "APTF",DGP TF,""))"RT N","DGPTFC LV",10,0)  S DIR(0)=" Y",DIR("A" )="CAMP LE JEUNE EXPO SURE INDIC ATED""RTN" ,"DGPTFCLV ",11,0) S  DGB=$P($G( ^DGPT(DGPT F,70)),U,3 3) D"RTN", "DGPTFCLV" ,12,0) . I  $G(DGB)'= "" S DIR(" B")=$S(DGB ="Y":"YES" ,1:"NO") Q "RTN","DGP TFCLV",13, 0) . I $G( DGB)="" S  DIR("B")=$ S($G(^DGPM (DGMV,"CLV "))="Y":"Y ES",1:"NO" )"RTN","DG PTFCLV",14 ,0) . Q"RT N","DGPTFC LV",15,0)  S DIR("?", 1)="Was tr eatment re lated to C amp Lejeun e?""RTN"," DGPTFCLV", 16,0) S DI R("?",2)=" Choose fro m:""RTN"," DGPTFCLV", 17,0) S DI R("?",3)="    Y          YES""RT N","DGPTFC LV",18,0)  S DIR("?") ="   N          NO""R TN","DGPTF CLV",19,0)  S DIR("?? ")="^D TWO Q^DGPTFCLV ""RTN","DG PTFCLV",20 ,0) D ^DIR "RTN","DGP TFCLV",21, 0) I X="^"  K DIR Q"R TN","DGPTF CLV",22,0)  I $G(Y)=1  S $P(^DGP T(DGPTF,70 ),U,33)="Y ""RTN","DG PTFCLV",23 ,0) I $G(Y )'=1 S $P( ^DGPT(DGPT F,70),U,33 )="N""RTN" ,"DGPTFCLV ",24,0) K  DIR Q"RTN" ,"DGPTFCLV ",25,0)PTF 101F ;FEE  BASIS CAMP  LEJEUNE E NTRY"RTN", "DGPTFCLV" ,26,0) N D GPTF,DIR,D GB,X,Y K D IR"RTN","D GPTFCLV",2 7,0) S DGP TF=PTF"RTN ","DGPTFCL V",28,0) S  DIR(0)="Y ",DIR("A") ="CAMP LEJ EUNE EXPOS URE INDICA TED""RTN", "DGPTFCLV" ,29,0) S D GB=$P($G(^ DGPT(DGPTF ,70)),U,33 ) D"RTN"," DGPTFCLV", 30,0) . I  $G(DGB)'=" " S DIR("B ")=$S(DGB= "Y":"YES", 1:"NO") Q" RTN","DGPT FCLV",31,0 ) . I $G(D GB)="" S D IR("B")="N O""RTN","D GPTFCLV",3 2,0) . Q"R TN","DGPTF CLV",33,0)  S DIR("?" ,1)="Was t reatment r elated to  Camp Lejeu ne?""RTN", "DGPTFCLV" ,34,0) S D IR("?",2)= "Choose fr om:""RTN", "DGPTFCLV" ,35,0) S D IR("?",3)= "   Y          YES""R TN","DGPTF CLV",36,0)  S DIR("?" )="   N          NO"" RTN","DGPT FCLV",37,0 ) S DIR("? ?")="^D TW OQ^DGPTFCL V""RTN","D GPTFCLV",3 8,0) D ^DI R"RTN","DG PTFCLV",39 ,0) I X="^ " K DIR Q" RTN","DGPT FCLV",40,0 ) I $G(Y)= 1 S $P(^DG PT(DGPTF,7 0),U,33)=" Y""RTN","D GPTFCLV",4 1,0) I $G( Y)'=1 S $P (^DGPT(DGP TF,70),U,3 3)="N""RTN ","DGPTFCL V",42,0) K  DIR Q"RTN ","DGPTFCL V",43,0)TW OQ ;TWO QU ESTION MAR KS HELP TE XT"RTN","D GPTFCLV",4 4,0) W !!? 3,"For thi s Veteran,  enter 'Y'  if the tr eatment fo r this enc ounter, vi sit,""RTN" ,"DGPTFCLV ",45,0) W  !?3,"or ad mission is  related t o a Vetera n's Camp L ejeune con dition. En ter 'N'""R TN","DGPTF CLV",46,0)  W !?3,"if  the treat ment for t his encoun ter, visit , or admis sion is no t related" "RTN","DGP TFCLV",47, 0) W !?3," to a Veter an's Camp  Lejeune co ndition."" RTN","DGPT FCLV",48,0 ) W !!,"Ch oose from: ",!?3,"Y          YES ""RTN","DG PTFCLV",49 ,0) W !?3, "N          NO""RTN", "DGPTFCLV" ,50,0) Q"R TN","DGPTF FB")0^70^B 8592145"RT N","DGPTFF B",1,0)DGP TFFB ;ALB/ JDS - FEE  BASIS PTF  ; 15 Dec 2 017  7:24  AM"RTN","D GPTFFB",2, 0) ;;5.3;R egistratio n;**914**; Aug 13, 19 93;Build 1 04"RTN","D GPTFFB",3, 0) ;"RTN", "DGPTFFB", 4,0)EN D L O^DGUTL F  DGDUMB=0:0  K DGPTOUT  D SEL Q:$ D(DGPTOUT) "RTN","DGP TFFB",5,0)  K DIPGM,D ISYS,DN,DG PTOUT,DGDU MB Q"RTN", "DGPTFFB", 6,0) ;"RTN ","DGPTFFB ",7,0)SEL  ; -- ask f or pt"RTN" ,"DGPTFFB" ,8,0) W !  K DIC"RTN" ,"DGPTFFB" ,9,0) S DI C(0)="AEQM Z",DIC("A" )="Enter N on-VA PTF  Patient: " ,DIC="^DPT (""RTN","D GPTFFB",10 ,0) D ^DIC  K DIC I Y '>0 S DGPT OUT="" G S ELQ"RTN"," DGPTFFB",1 1,0) S (DA ,DFN)=+Y D  INFO"RTN" ,"DGPTFFB" ,12,0) ;"R TN","DGPTF FB",13,0)A D ; -- ask  for adm d ate"RTN"," DGPTFFB",1 4,0) R !!, "Enter NEW  Non-VA PT F Admissio n Date: ", X:DTIME G  SELQ:(U[X) !('$T) S % DT="XETP"  D ^%DT G A D:Y<200000 0 S DGADM= +Y D CHK G  AD:'Y"RTN ","DGPTFFB ",15,0) ;" RTN","DGPT FFB",16,0)  ; -- crea te new PTF  rec"RTN", "DGPTFFB", 17,0) S Y= 1 D RTY^DG PTUTL S Y= DGADM_"^1"  D CREATE^ DGPTFCR S  PTF=+Y"RTN ","DGPTFFB ",18,0) ;C LT, ADD DE FAULT ANSW ER OF "NO"  TO SCREEN  101 FEE B ASIS ADMIS SION ;DG*5 .3*914"RTN ","DGPTFFB ",19,0) S  $P(^DGPT(P TF,70),U,3 3)="N""RTN ","DGPTFFB ",20,0) ;" RTN","DGPT FFB",21,0)  ; -- go t o load edi t"RTN","DG PTFFB",22, 0) S DGREL =$S($D(^XU SEC("DG PT FREL",DUZ) ):1,1:0),D GADPR=9999 999,DGPR=0 ,DGST=0,DG PTFE=1 K D GDFN"RTN", "DGPTFFB", 23,0) D IN COME^DGPTU TL1,GETD^D GPTF"RTN", "DGPTFFB", 24,0) ;"RT N","DGPTFF B",25,0)SE LQ K DGADM ,DGPTF,POP ,D0,C,DN,P TF,DFN,DGR EL,DA,DGAD PR,DGDD,DG DFN,DIC,DI E,DIK,DR,I ,L,X,Y,DGR TY,DGRTY0" RTN","DGPT FFB",26,0)  Q"RTN","D GPTFFB",27 ,0) ;"RTN" ,"DGPTFFB" ,28,0)INFO  ; -- brie f PTF rec  profile fo r DFN pt"R TN","DGPTF FB",29,0)  ; -- is te mplate com piled?"RTN ","DGPTFFB ",30,0) S  X="DGPTXB"  X ^%ZOSF( "TEST") K  DXS G INFO Q:'$T"RTN" ,"DGPTFFB" ,31,0) S I OP="HOME"  D ^%ZIS K  IOP D PID^ VADPT6"RTN ","DGPTFFB ",32,0) W  @IOF,?5,"* ***   PTF  Record Pro file for " ,$E($P(Y(0 ),U),1,25) ,"  (",VA( "PID"),")   ****""RTN ","DGPTFFB ",33,0) D  HEAD^DGPTX B K DGPTX  S DGPTCNT= 0,DGPTMAX= $S($D(DGPT MAX):+DGPT MAX,1:15)" RTN","DGPT FFB",34,0)  ; -- sort  in invers e date ord er"RTN","D GPTFFB",35 ,0) F I=0: 0 S I=$O(^ DGPT("B",D FN,I)) Q:' I  I $D(^D GPT(I,0))  S DGPTX(99 99999.9999 99-$P(^(0) ,"^",2),I) ="""RTN"," DGPTFFB",3 6,0) ; --  display da ta"RTN","D GPTFFB",37 ,0) I $D(D GPTX) F DG PTX=0:0 S  DGPTX=$O(D GPTX(DGPTX )) Q:'DGPT X  S DGPTC NT=DGPTCNT +1 Q:DGPTC NT>DGPTMAX   F PTF=0: 0 S PTF=$O (DGPTX(DGP TX,PTF)) Q :'PTF  S D 0=PTF K DX S D ^DGPTX B W !"RTN" ,"DGPTFFB" ,38,0) I D GPTCNT>DGP TMAX W !?5 ,"...only  last ",DGP TMAX," rec ords are d isplayed." "RTN","DGP TFFB",39,0 ) I '$D(DG PTX) W !?5 ," No PTF  records on  file for  patient."" RTN","DGPT FFB",40,0) INFOQ K DX S,DGPTCNT, DGPTX,VA,D 0,PTF,DGPT MAX"RTN"," DGPTFFB",4 1,0) Q"RTN ","DGPTFFB ",42,0) ;" RTN","DGPT FFB",43,0) CHK ; -- c heck if ad m on date  already ex ists"RTN", "DGPTFFB", 44,0) K Y" RTN","DGPT FFB",45,0)  F I=0:0 S  I=$O(^DGP T("B",DFN, I)) Q:'I   I $D(^DGPT (I,0)),$P( DGADM,".") =$P($P(^(0 ),U,2),"." ) S Y=$P(^ (0),U,2) Q "RTN","DGP TFFB",46,0 ) I '$D(Y)  S Y=1 G C HKQ"RTN"," DGPTFFB",4 7,0) X ^DD ("DD") W ! !,*7,"PTF  #",I," alr eady exist  for that  admission  date (",Y, ").",!"RTN ","DGPTFFB ",48,0) S  DIR(0)="Y" ,DIR("A")= "Do you st ill want t o create a  new PTF"" RTN","DGPT FFB",49,0)  S DIR("?" ,1)="Answe r 'Yes' to  add a new  PTF recor d""RTN","D GPTFFB",50 ,0) S DIR( "?",2)="        'NO'   to not ad d another  PTF record ""RTN","DG PTFFB",51, 0) S DIR(" ?")=" ""RT N","DGPTFF B",52,0) S  DIR("B")= "NO" D ^DI R K DIR"RT N","DGPTFF B",53,0)CH KQ Q"RTN", "DGPTFM")0 ^18^B84539 163"RTN"," DGPTFM",1, 0)DGPTFM ; ALB/MTC/PL T - PTF OP -PRO-DIAG  ;07/01/201 5  8:03 AM "RTN","DGP TFM",2,0)  ;;5.3;Regi stration;* *510,517,5 90,594,606 ,635,683,6 96,664,850 ,884,914** ;Aug 13, 1 993;Build  104"RTN"," DGPTFM",3, 0) ;;Per V A Directiv e 6402, th is routine  should no t be modif ied."RTN", "DGPTFM",4 ,0) ;"RTN" ,"DGPTFM", 5,0) K X1, M,S,P,M1,M 2,M3,S1,S2 ,PS2,P1,P2 ,P1P,P2P,S DCLY,^TMP( "PTF",$J)" RTN","DGPT FM",6,0) N  EFFDATE,I MPDATE,DGM OVCNT,DGSU RCNT,DGPRO CNT,DGMMOR E,DGPMORE" RTN","DGPT FM",7,0) D  EFFDATE^D GPTIC10(PT F)"RTN","D GPTFM",8,0 ) S DGMOVC NT=0,DGSUR CNT=0,DGPR OCNT=0"RTN ","DGPTFM" ,9,0) S I= 0 F I1=1:1  S I=$O(^D GPT(PTF,"M ",I)) Q:'I   S DGMOVC NT=$G(DGMO VCNT)+1"RT N","DGPTFM ",10,0) S  I=0 F I1=1 :1 S I=$O( ^DGPT(PTF, "S",I)) Q: 'I  S DGSU RCNT=$G(DG SURCNT)+1" RTN","DGPT FM",11,0)  S I=0 F I1 =1:1 S I=$ O(^DGPT(PT F,"P",I))  Q:'I  S DG PROCNT=$G( DGPROCNT)+ 1"RTN","DG PTFM",12,0 ) S I=0 F  I1=1:1:5 S  I=$P($G(^ DGPT(PTF," 401P")),U, I1) I +I S  DGPRCNT=$ G(DGPRCNT) +1"RTN","D GPTFM",13, 0) S DGMMO RE=$G(DGSU RCNT)+$G(D GPROCNT)+$ G(DGPRCNT) "RTN","DGP TFM",14,0)  S DGPMORE =$G(DGPROC NT)+$G(DGP RCNT)"RTN" ,"DGPTFM", 15,0) ;"RT N","DGPTFM ",16,0)GET  ;set m,m3  local arr ay of move ment recor ds"RTN","D GPTFM",17, 0) S I=0 F  I1=1:1 S  I=$O(^DGPT (PTF,"M",I )) Q:'I  D "RTN","DGP TFM",18,0)  . S M(I1) =^(I,0),M3 (+M(I1))=M (I1) ;,M(I 1,82)=$G(^ DGPT(PTF," M",I,82))" RTN","DGPT FM",19,0)  . I $D(^DG PT(PTF,"M" ,I,"P")) S  $P(M(I1), U,20)=^("P ")"RTN","D GPTFM",20, 0) . QUIT" RTN","DGPT FM",21,0)  ;sort m ar ray in chr onological  order for  display,  not m3"RTN ","DGPTFM" ,22,0) K M T D ORDER^ DGPTF K MT "RTN","DGP TFM",23,0)  D GETVAR^ DGPTFM6,CL ^SDCO21(DF N,$P(^DGPT (PTF,0),U, 2),"",.SDC LY),MOB^DG PTFM2"RTN" ,"DGPTFM", 24,0) S DG PC=I1-1"RT N","DGPTFM ",25,0) D  WR ; creat es header" RTN","DGPT FM",26,0)  K M1,M2,^U TILITY($J) "RTN","DGP TFM",27,0)  S ST=1,M2 =0"RTN","D GPTFM",28, 0)DIAG ;"R TN","DGPTF M",29,0) K  DGZSER,DG ZPRO,DGZSU R S DGZDIA G=1"RTN"," DGPTFM",30 ,0) G PRO1 :$Y>16 W ! "RTN","DGP TFM",31,0)  F J=ST:1: PM S NL=1, L5=0,L6=J  D WD2,WD G  PRO1:$Y>1 6 D WD3^DG PTFM8 W !" RTN","DGPT FM",32,0)  S ST=1 G S ER"RTN","D GPTFM",33, 0)WD ;"RTN ","DGPTFM" ,34,0) N D GMPOA"RTN" ,"DGPTFM", 35,0) D EF FDATE^DGPT IC10(PTF)" RTN","DGPT FM",36,0)  W !?2,"Mov ement Diag nosis: ",$ $GETLABEL^ DGPTIC10(D GPTDAT,"D" )"RTN","DG PTFM",37,0 ) ;F J1=1: 1:11 I J1' =6 S L=$P( M(J),U,J1+ 4),L1=0,L3 =1 I +L D" RTN","DGPT FM",38,0)  D PTFICD^D GPTFUT(501 ,PTF,+M(J) ,.DGX501)" RTN","DGPT FM",39,0)  S J1=0 F   S J1=$O(DG X501(J1))  QUIT:'J1   S L=DGX501 (J1),L1=0, L3=1 I +L  D"RTN","DG PTFM",40,0 ) . S DGMP OA=$P(L,U, 2)"RTN","D GPTFM",41, 0) . D:+L  WD1"RTN"," DGPTFM",42 ,0) . QUIT "RTN","DGP TFM",43,0)  K DGX501" RTN","DGPT FM",44,0)  QUIT"RTN", "DGPTFM",4 5,0)WD1 ;" RTN","DGPT FM",46,0)  S N=$$ICDD ATA^ICDXCO DE("DIAG", +L,EFFDATE ),M2=M2+1" RTN","DGPT FM",47,0)  W !,?L1,$J (M2,3)," " "RTN","DGP TFM",48,0)  D WRITECO D^DGPTIC10 ("DIAG",+L ,EFFDATE,1 ,0,0)"RTN" ,"DGPTFM", 49,0) I $P (N,U,20)=3 0 W:$X>73  !,"             " W "  (POA=",$S (DGMPOA]"" :DGMPOA,1: "''"),")"" RTN","DGPT FM",50,0)  W $S(+N<1! ('$P(N,U,1 0)):"*",1: "")"RTN"," DGPTFM",51 ,0) K ^UTI LITY($J,"M 2",M2) S ^ UTILITY($J ,"M2",M2)= +M(J+L1)_U _J1_U_(+L) _U_DGMPOA" RTN","DGPT FM",52,0)  I $Y>(IOSL -4) D PGBR  W @IOF,HE AD,?70 S Z ="<MAS>" D  Z W !"RTN ","DGPTFM" ,53,0) QUI T"RTN","DG PTFM",54,0 )WD2 ;"RTN ","DGPTFM" ,55,0) N Z 3"RTN","DG PTFM",56,0 ) W !?L5," Move #",+L 6 S Z=M(L6 ),Z3=M3(+Z ) W:+Z=1 "  D/C" S Y= $P(Z,U,10) \1 D D^DGP TUTL W " " ,Y," ""RTN ","DGPTFM" ,57,0) W "  <",$S($P( Z3,U,18)=1 :"",1:"N") ,"SC"_$S($ P(Z3,U,26) ="Y":",AO" ,1:"")_$S( $P(Z3,U,27 )="Y":",IR ",1:"")_$S ($P(Z3,U,2 8)="Y":",S WAC",1:"") _$S($P(Z3, U,32)="Y": ",SHAD",1: "")_">""RT N","DGPTFM ",58,0) I  $D(^DIC(42 .4,+$P(Z,U ,2),0)) D" RTN","DGPT FM",59,0)  . I $P(^DI C(42.4,+$P (Z,U,2),0) ,U,2)'=""  W $E($P(^D IC(42.4,+$ P(Z,U,2),0 ),U,2),1,1 0)"RTN","D GPTFM",60, 0) . E  W  $E($P(^(0) ,U,1),1,10 ) ;^(0) re ferences g lobal in l ine above" RTN","DGPT FM",61,0)  . QUIT"RTN ","DGPTFM" ,62,0) QUI T"RTN","DG PTFM",63,0 ) ;"RTN"," DGPTFM",64 ,0)NDG D W R S I=0 K  M,M1,M2 S  M2=0 F I1= 1:1 S I=$O (^DGPT(PTF ,"M",I)) Q :I'>0  S M (I1)=^(I,0 ) ;,M(I1,8 2)=$G(^DGP T(PTF,"M", I,82))"RTN ","DGPTFM" ,65,0) ;so rt m array  in chrono logical or der for di splay"RTN" ,"DGPTFM", 66,0) S PM =I1-1 D OR DER^DGPTF  K MT G DIA G:$D(ST) G  GET S ST= 1"RTN","DG PTFM",67,0 ) ;"RTN"," DGPTFM",68 ,0)SER ;"R TN","DGPTF M",69,0) K  DGZDIAG,D GZPRO,DGZS UR"RTN","D GPTFM",70, 0) S DGZSE R=1"RTN"," DGPTFM",71 ,0) ;G PRO 1:$Y>19"RT N","DGPTFM ",72,0) K  S1,S2"RTN" ,"DGPTFM", 73,0) S S2 =0 G SERV: ST G PRO"R TN","DGPTF M",74,0) ; "RTN","DGP TFM",75,0) SERV ;"RTN ","DGPTFM" ,76,0) ;F  J=ST:2:SU  S NL=1,L5= 0,L6=J D S D2 S L5=1, L6=J+1 D:$ D(S(L6)) S D2 D SD G  PRO1:$Y>11  D SD3^DGP TFM8 G PRO 1:$Y>11 W  !"RTN","DG PTFM",77,0 ) F J=ST:1 :SU S NL=1 ,L5=0,L6=J  D SD2,SD  D SD3^DGPT FM8 G:(J<S U) PRO1:$Y >12 W !"RT N","DGPTFM ",78,0) K  DGZSER"RTN ","DGPTFM" ,79,0) G P RC^DGPTFM0 "RTN","DGP TFM",80,0) SD ;"RTN", "DGPTFM",8 1,0) ;F J1 =1:1:5 S L =$P(S(J),U ,J1+7),L1= 0,L3=1 D:+ L SD1"RTN" ,"DGPTFM", 82,0) D PT FICD^DGPTF UT(401,PTF ,S(J,1),.D GX401)"RTN ","DGPTFM" ,83,0) S J 1=0 F  S J 1=$O(DGX40 1(J1)) QUI T:'J1  S L =DGX401(J1 ),L1=0,L3= 1 D:+L SD1 "RTN","DGP TFM",84,0)  K DGX401" RTN","DGPT FM",85,0)  QUIT"RTN", "DGPTFM",8 6,0)SD1 ;" RTN","DGPT FM",87,0)  S N=$$ICDD ATA^ICDXCO DE("PROC", +L,EFFDATE )"RTN","DG PTFM",88,0 ) S S2=S2+ 1"RTN","DG PTFM",89,0 ) W !,?L1, $J(S2,3),"  " D WRITE COD^DGPTIC 10("PROC", +L,EFFDATE ,1,0,0)  W  $S(+N<1!( '$P(N,U,10 )):"*",1:" ")"RTN","D GPTFM",90, 0) K S2(S2 ) S S2(S2) =J+L1_U_J1 _U_(+L)"RT N","DGPTFM ",91,0) I  $Y>(IOSL-4 ) D PGBR W  @IOF,HEAD ,?70 S Z=" <MAS>" D Z  W !"RTN", "DGPTFM",9 2,0) Q"RTN ","DGPTFM" ,93,0) ;"R TN","DGPTF M",94,0)SD 2 ;"RTN"," DGPTFM",95 ,0) S Y=+S (L6) D D^D GPTUTL W ! ?L5,L6,"-S urgery dat e: ",Y,$$G ETLABEL^DG PTIC10(EFF DATE,"P")" RTN","DGPT FM",96,0)  Q"RTN","DG PTFM",97,0 )NSR K S,S 1,S2 S I=0  F I1=1:1  S I=$O(^DG PT(PTF,"S" ,I)) Q:I'> 0  S S(I1) =^(I,0),S( I1,1)=I"RT N","DGPTFM ",98,0) S  S2=0,SU=I1 -1 D WR G  SERV"RTN", "DGPTFM",9 9,0) ;"RTN ","DGPTFM" ,100,0)WR  W @IOF,HEA D,?70 S Z= "<MAS>" D  Z"RTN","DG PTFM",101, 0) Q"RTN", "DGPTFM",1 02,0)PRO ; load 401p  code befor e 2871000" RTN","DGPT FM",103,0)  K DGZSER, DGZDIAG,DG ZSUR"RTN", "DGPTFM",1 04,0) S DG ZPRO=1"RTN ","DGPTFM" ,105,0) G: $G(DGPRCNT ) PRO1:$Y> 14"RTN","D GPTFM",106 ,0) K P1P, P2P S ST=1 ,P2P=0"RTN ","DGPTFM" ,107,0) G  NPR:'$D(PR OC)"RTN"," DGPTFM",10 8,0) ;"RTN ","DGPTFM" ,109,0)PRO C ; Displa y procedur es in fiel d 45.01 -  45.05"RTN" ,"DGPTFM", 110,0) ;"R TN","DGPTF M",111,0)  G PRO1:$Y> 14 ;D:$Y>1 4 WR"RTN", "DGPTFM",1 12,0) S PR OC=$S($D(^ DGPT(PTF," 401P")):^( "401P"),1: "")"RTN"," DGPTFM",11 3,0) F PR= 1:1:5 S DG PROC=$G(DG PROC)_$P(P ROC,"^",PR )"RTN","DG PTFM",114, 0) K PR"RT N","DGPTFM ",115,0) W :DGPROC]""  !,"Proced ures: ",$$ GETLABEL^D GPTIC10(DG PTDAT,"P") "RTN","DGP TFM",116,0 ) F J1=1:1 :5 S L=$P( PROC,"^",J 1) I L'=""  S P2P=P2P +1 D"RTN", "DGPTFM",1 17,0) . S  N=$$ICDDAT A^ICDXCODE ("PROC",+L ,EFFDATE)" RTN","DGPT FM",118,0)  . S L2=$S (N:$P(N,U, 2,99),1:"" )"RTN","DG PTFM",119, 0) . W !,$ J(P2P,3),"  " D WRITE COD^DGPTIC 10("PROC", +L,EFFDATE ,1,0,0)"RT N","DGPTFM ",120,0) .  W $S(+N<1 !('$P(N,U, 10)):"*",1 :"")"RTN", "DGPTFM",1 21,0) . K  P2P(P2P) S  P2P(P2P)= J1 W:$X>45  !"RTN","D GPTFM",122 ,0) K DGZS ER,DGZPRO, DGZDIAG,DG ZSUR"RTN", "DGPTFM",1 23,0) ;"RT N","DGPTFM ",124,0)EN C ;G PRO1: $Y>7,PRO1: '$P(DGZPRF ,U,3)"RTN" ,"DGPTFM", 125,0) G P RO1:'$P(DG ZPRF,U,3)" RTN","DGPT FM",126,0)  G PRO1:$Y >12"RTN"," DGPTFM",12 7,0) ;"RTN ","DGPTFM" ,128,0)PF  S PS2=0,J= +DGZPRF,Y= +DGZPRF(J) ,DGSTRT=$S (+$P(DGZPR F,U,4):$P( DGZPRF,U,4 ),1:4),DGL ST=0"RTN", "DGPTFM",1 29,0) D CL ^SDCO21(DF N,+DGZPRF( J),"",.SDC LY),ICDINF O^DGAPI(DF N,PTF),XRE F^DGPTFM21  ; load SC I info and  DGN's for  this serv ice date"R TN","DGPTF M",130,0)  D D^DGPTUT L W !,J,"- CPT Captur e Date/Tim e: ",Y W:( $P(DGZPRF, U,2)-1!($G (PGBRK)))  " (cont.)" "RTN","DGP TFM",131,0 ) I $P(DGZ PRF(J),U,2 ) W !,?5," Referring  or Orderin g Provider : " S L=$P (DGZPRF(J) ,U,2) D PR V"RTN","DG PTFM",132, 0) W !,?5, "Rendering  Provider:  " S L=$P( DGZPRF(J), U,3) D PRV "RTN","DGP TFM",133,0 ) I $P(DGZ PRF(J),U,5 ) W !,?5," Rendering  Location:  ",$P($G(^S C($P(DGZPR F(J),U,5), 0)),U)"RTN ","DGPTFM" ,134,0) S  (L1,PGBRK) =0"RTN","D GPTFM",135 ,0) F K=$P (DGZPRF,U, 2):1 Q:'$D (DGZPRF(J, K))  I '$G (DGZPRF(J, K,9)) S PS 2=PS2+1 W  !,?2,PS2,"  " D CPT^D GPTUTL1 D   Q:$Y+$G(D GZPRF(J,K+ 1,1))>16!( $G(PGBRK)) "RTN","DGP TFM",136,0 ) .; Add 8 01 logic"R TN","DGPTF M",137,0)  . W !,?4 S  $P(DS,"-" ,21)="" W  DS," Relat ed Diagnos is",$$GETL ABEL^DGPTI C10(+DGZPR F(J),"D"), " ",DS"RTN ","DGPTFM" ,138,0) .  F L1=DGSTR T:1:11 S D GLOC=$S(L1 <8:L1,1:L1 +7),CD=$P( DGZPRF(J,K ),U,DGLOC)  I CD D  I  $Y+$G(CKS CI)>16 S P GBRK=1 Q"R TN","DGPTF M",139,0)  . . S N=$$ ICDDATA^IC DXCODE("DI AG",CD,+DG ZPRF(J)) ; ,N=$S(N:$P (N,U,2,99) ,1:"")"RTN ","DGPTFM" ,140,0) .  . D WRITEC OD^DGPTIC1 0("DIAG",C D,+DGZPRF( J),2,1,8)" RTN","DGPT FM",141,0)  . . W $S( +N<1!('$P( N,U,10)):" *",1:"")"R TN","DGPTF M",142,0)  . . D CKSC I($P(DGZPR F(J,K),U,D GLOC))"RTN ","DGPTFM" ,143,0) .  S PS2(PS2) =J_U_K,CD= 1,DGLOC=0, DGSTRT=4"R TN","DGPTF M",144,0)  I L1'=11,$ S(L1<8:$P( $G(DGZPRF( J,K)),U,L1 +1,7),1:"" )_$P($G(DG ZPRF(J,K)) ,U,$S(L1<8 :15,1:L1+8 ),18)?."^"  S L1=11"R TN","DGPTF M",145,0)  I L1=11 S  $P(DGZPRF, U,1,2)=$S( $D(DGZPRF( J,K+1)):J_ U_(K+1),1: J+1_U_1),$ P(DGZPRF,U ,4)="",PGB RK=0"RTN", "DGPTFM",1 46,0) E  S  $P(DGZPRF ,U,1,2)=J_ U_K,$P(DGZ PRF,U,4)=L 1+1"RTN"," DGPTFM",14 7,0) K I,K ,L,L1,CD,N ,DS G PRO1 "RTN","DGP TFM",148,0 ) ;"RTN"," DGPTFM",14 9,0)CKSCI( IEN)       ;print SCI  for each  Diagnosis  code"RTN", "DGPTFM",1 50,0) N DG INFO Q:'$D (XREF(IEN) )"RTN","DG PTFM",151, 0) S DGINF O=$G(^DGIC D9(46.1,(X REF(IEN)), 0)),CKSCI= 0"RTN","DG PTFM",152, 0) I 'DGIN FO Q"RTN", "DGPTFM",1 53,0) ;JMM  DG*5.3*91 4 RSD SPEC # 2.6.5.2. 3.2 <MAS>  Screen Cam p Lejeune  - Add 9 to  FOR list  below to i nclude Cam p Lejeune  question b elow"RTN", "DGPTFM",1 54,0) F I= 3,7,1,2,4, 5,6,8,9 I  $D(SDCLY(I )) S L=$S( I=3:8,I<4: 8+I,1:7+I)  D"RTN","D GPTFM",155 ,0) .W ?45  S M=1,CKS CI=CKSCI+1 "RTN","DGP TFM",156,0 ) .W !?8"R TN","DGPTF M",157,0)  .;JMM DG*5 .3*914 RSD  SPEC# 2.6 .5.2.3.2 < MAS> Scree n Camp Lej eune - Add  Camp Leje une questi on to list  below"RTN ","DGPTFM" ,158,0) .W  $P("Treat ed for AO  Condition^ Treated fo r IR Condi tion^Treat ed for SC  Condition^ Exposed to  SW Asia C onditions^ Treatment  for MST^Tr eatment fo r Head/Nec k CA^Relat ed to Comb at^Treatme nt for SHA D Conditio n^Treatmen t for Camp  Lejeune", U,I)"RTN", "DGPTFM",1 59,0) .W " : ",$S($P( DGINFO,U,( $S(I<3:I+2 ,I=3:2,1:I +1))):"YES ",1:"NO"), !"RTN","DG PTFM",160, 0) Q  ;CKS CI"RTN","D GPTFM",161 ,0) ;"RTN" ,"DGPTFM", 162,0)NPR  S ST=1,PRO C=$S($D(^D GPT(PTF,"4 01P")):^(" 401P"),1:" ") D WR G  PRO"RTN"," DGPTFM",16 3,0) ;"RTN ","DGPTFM" ,164,0)NPS  D WR G PF "RTN","DGP TFM",165,0 ) ;"RTN"," DGPTFM",16 6,0)DONE G  EN1^DGPTF 4"RTN","DG PTFM",167, 0)PRO1 ;SE T MENU TYP E AND DISP LAY MENU"R TN","DGPTF M",168,0)  N ICDVDT,I CPTVDT"RTN ","DGPTFM" ,169,0) I  $G(PTF)'=" ",$G(EFFDA TE)="" D E FFDATE^DGP TIC10(PTF) "RTN","DGP TFM",170,0 ) S (ICDVD T,ICPTVDT) =$S($G(EFF DATE)'="": EFFDATE,$D (PTF):$$GE TDATE^ICDG TDRG(PTF), 1:DT)"RTN" ,"DGPTFM", 171,0) S D GNUM=$S($D (DGZDIAG)! ($D(DGZPRO ))!($D(DGZ SER))!($D( DGZSUR)!(+ DGZPRF-1'= $P(DGZPRF, U,3))):"MA S",1:"701" ) G MAS^DG PTFJC:DGST  F X=$Y:1: (IOSL-9) W  !"RTN","D GPTFM",172 ,0) W !! S  Z="Patien t Movement s:" W Z S  Z=" "_$S(D GPTFE:"M=A dd PM  X=D elete PM", 1:"M=Edit  Treat Spec /PM ")_"   A=Add Code   D=Delete  Code  V=E dit Mov" W  Z"RTN","D GPTFM",173 ,0) W ! S  Z="Surgica l Episodes :" W Z S Z =" S=Add S E  Z=Delet e SE  O=Ad d Code  C= Delete Cod e  J=Edit  SE" W Z"RT N","DGPTFM ",174,0) W  ! S Z="Pr ocedure Re cords:" W  Z S Z=" T= Add PR  R= Delete PR   P=Add Cod e  Q=Delet e Code  E= Edit PR" W  Z"RTN","D GPTFM",175 ,0) W ! S  Z="               801 :" W Z S Z =" I=Add 8 01 Y=Delet e 801 N=Ad d CPT   G= Delete CPT    F=Edit  801" W Z K  Z"RTN","D GPTFM",176 ,0) W !,"                     ^= Abort   <R ET> to Con tinue:<",D GNUM,">//  " R ANS:DT IME K DGNU M"RTN","DG PTFM",177, 0)A S Z="^ C Delete C ode^A Add  Code^O Add  Code^P Ad d NOP^S Ad d SE^D Del ete Code^M  Add PM^X  Delete PM^ Z Delete S E^J Edit S E^Q Delete  NOP^V Edi t Move^""R TN","DGPTF M",178,0)  S Z=Z_"T A dd PR^R De lete PR^E  Edit PR^I  Add 801^Y  Delete 801 ^N Add CPT ^G Delete  CPT^F Edit  801""RTN" ,"DGPTFM", 179,0) I ' DGPTFE S $ P(Z,U,8,9) ="M Edit t reat Spec/ PM""RTN"," DGPTFM",18 0,0) S X=A NS G Q^DGP TF:ANS="^"  G ^DGPTFJ :ANS?1"^". E S (A,X)= ANS,X=$E(X ,1) D IN^D GHELP"RTN" ,"DGPTFM", 181,0) I $ P(^DGPT(PT F,0),U,4), X'="","IYN GF"[X W !, "***WARNIN G: This is  a Fee Bas is PTF rec ord*** 801  encounter s are not  allowed."  H 3 G DGPT FM"RTN","D GPTFM",182 ,0) I ANS= "" S (ST,S T1)=J+1 D: $D(DGZSUR)  WR G @($S ($D(DGZDIA G):"NDG",$ D(DGZSER): "NSR",$D(D GZPRO):"NP R",$D(DGZS UR):"EN^DG PTFM0",+DG ZPRF-1'=$P (DGZPRF,U, 3):"NPS",1 :"DONE"))" RTN","DGPT FM",183,0)  G HELP^DG PTFM1A:$G( %)=-1 S Z= $L(A)-1 G  @(X_$S(X=" X":"",1:"^ DGPTFM1")) "RTN","DGP TFM",184,0 )PRV I $D( ^VA(200,L, 0)) W $P(^ (0),U) Q"R TN","DGPTF M",185,0)  W L Q"RTN" ,"DGPTFM", 186,0)X ;" RTN","DGPT FM",187,0)  I 'Z S:PM =1 RC=1 G  X1:PM=1 W  !!,"Delete  Patient m ove <1",$S (PM<3:"",1 :"-"_(PM-1 )),">: " R  RC:DTIME  G ^DGPTFM: RC["^"!(RC ="")"RTN", "DGPTFM",1 88,0) E  S  RC=$E(A,2 ,99) W !"R TN","DGPTF M",189,0)  I +RC'=RC! ('$D(M(RC) )) W !!,"E nter the r ecord # to  delete fr om the PTF  file, 1", $S(PM<3:"" ,1:"-"_(PM -1)) S Z=0  G X"RTN", "DGPTFM",1 90,0)X1 I  +M(RC)=1 W  !,*7,"Can not delete  discharge  movement" ,! H 3 G ^ DGPTFM"RTN ","DGPTFM" ,191,0) S  DIE="^DGPT ("_PTF_"," "M"",",DP= 45.02,DR=" .01///@",D A(1)=PTF,D A=+M(RC) D  ^DIE K DR  W "  ",RC ,"-DELETED ***" H 2 G  ^DGPTFM"R TN","DGPTF M",192,0)Z  ;"RTN","D GPTFM",193 ,0) W @DGV I,Z,@DGVO  Q  ; Write s reverse  video"RTN" ,"DGPTFM", 194,0)EN D  WR G EN^D GPTFM0"RTN ","DGPTFM" ,195,0) Q" RTN","DGPT FM",196,0)  ;"RTN","D GPTFM",197 ,0)PGBR N  DIR,X,Y S  DIR(0)="E" ,DIR("A")= "Enter RET URN to con tinue" D ^ DIR QUIT"R TN","DGPTF M",198,0)  ;"RTN","DG PTFM21")0^ 48^B156238 29"RTN","D GPTFM21",1 ,0)DGPTFM2 1 ;ALB/DWS  - MASTER  PROFESSION AL SERVICE  ENTER/EDI T(CONT.) ; 5/24/05 1: 04pm"RTN", "DGPTFM21" ,2,0) ;;5. 3;Registra tion;**635 ,914**;Aug  13, 1993; Build 104" RTN","DGPT FM21",3,0) GETINFO ;G ET PROCEDU RE CODE IN FORMATION" RTN","DGPT FM21",4,0)  N NOKILL, EXITFLAG,D GNIEN"RTN" ,"DGPTFM21 ",5,0) S N OKILL=1,EX ITFLG=0,ER RFLG=0,DGD IAG=0"RTN" ,"DGPTFM21 ",6,0) D I CDINFO^DGA PI(DFN,PTF )  ;gather  all DGN c odes for t he patient "RTN","DGP TFM21",7,0 ) D XREF S  DIE="^DGC PT(46,""RT N","DGPTFM 21",8,0) D  SDR,FMDIE ^DGPTFM2   ;prompt fo r CPT Code  and modif iers"RTN", "DGPTFM21" ,9,0) I $D (Y)>9 S DU OUT=1 Q"RT N","DGPTFM 21",10,0)  I $G(ERRFL G)=1 Q  ;c annot lock  REC in DG CPT - exit "RTN","DGP TFM21",11, 0) S DGDIA G=1"RTN"," DGPTFM21", 12,0) S DR ="" F PIEC E=4:1:7,21 :1:24 S:PI ECE=24 NOK ILL=0 D  Q :EXITFLG!$ D(DUOUT)   ;Go thru a ll existin g DGN's in  DGCPT fil e"RTN","DG PTFM21",13 ,0) . S DI E="^DGCPT( 46," D SDR 2(PIECE),F MDIE^DGPTF M2 I $D(Y) >9 S DUOUT =1 Q"RTN", "DGPTFM21" ,14,0) . I  ('$$CHKDG NS(DA,PIEC E))!($D(Y) >9)!($D(DT OUT)) S EX ITFLG=1 Q   ;Prompt w /existing  DGN cd if  it exists" RTN","DGPT FM21",15,0 ) . S DR=" ",SAVDA=DA ,DGNIEN=$P (^DGCPT(46 ,DA,0),U,$ S(PIECE<20 :PIECE,1:P IECE-6)) Q :DGNIEN="" "RTN","DGP TFM21",16, 0) . I '$D (XREF(DGNI EN)) D  ;t he IEN to  be added h as not yet  been defi ned in DGI CD9, it mu st be adde d before p roceeding" RTN","DGPT FM21",17,0 ) . . K DO  S DIC="^D GICD9(46.1 ,",DIC(0)= "LMZ",DLAY GO=46,X=DG NIEN"RTN", "DGPTFM21" ,18,0) . .  D FILE^DI CN Q:$D(DU OUT)  I Y< 0 S ERRFLG =1"RTN","D GPTFM21",1 9,0) . . I  'ERRFLG S  XREF(DGNI EN)=+Y ; s etup info  to build " B" xref in  DGICD9 fo r new entr y"RTN","DG PTFM21",20 ,0) . I ER RFLG S EXI TFLG=1 Q   ;could not  add new D GN ien to  DGICD9 - e xit loop w ith error" RTN","DGPT FM21",21,0 ) . D SCI( DGNIEN):0  S UPDTD=0, (DA,REC)=X REF(DGNIEN ) ;determi ne if any  SCI prompt s should b e done for  this DGN" RTN","DGPT FM21",22,0 ) . K ^TMP ("PTF",$J)   ;Clean u p TMP file  to pass i nfo to be  filed in 4 6.1"RTN"," DGPTFM21", 23,0) . S  DIE="^DGIC D9(46.1,", DR="[DG801 ]"  ;SCI f lags to be  stored in  file 46.1 "RTN","DGP TFM21",24, 0) . ;prom pt for SCI  y/n and f ile in 46. 1"RTN","DG PTFM21",25 ,0) . I DR '="" D FMD IE^DGPTFM2  S DR="",U PDTD=1 I $ D(Y)>9 S D UOUT=1 Q"R TN","DGPTF M21",26,0)  . I 'UPDT D D"RTN"," DGPTFM21", 27,0) . .  S ^TMP("PT F",$J,46.1 ,1)="^"_DG NIEN"RTN", "DGPTFM21" ,28,0) . .  S X=$$DAT A2PTF^DGAP I(DFN,PTF, DGPRD) ;If  there wer e no SCI's  prompts,  stuff DGN  into file  46.1"RTN", "DGPTFM21" ,29,0) . S  DA=SAVDA" RTN","DGPT FM21",30,0 ) K DIR,RE C"RTN","DG PTFM21",31 ,0) Q  ;GE TINFO"RTN" ,"DGPTFM21 ",32,0)XRE F ;create  xref for ^ TMP global  containin g DGICD9 i nfo to hav e access v ia DGN IEN  in local  array XREF "RTN","DGP TFM21",33, 0) N SEQ,N ODE,INFO,I EN"RTN","D GPTFM21",3 4,0) K XRE F"RTN","DG PTFM21",35 ,0) S SEQ= 0"RTN","DG PTFM21",36 ,0) F  S S EQ=$O(^TMP ("PTF",$J, 46.1,SEQ))  Q:'SEQ  S  INFO=^(SE Q),NODE=+I NFO,IEN=$P (INFO,U,2) ,XREF(IEN) =NODE"RTN" ,"DGPTFM21 ",37,0) Q   ;XREF"RTN ","DGPTFM2 1",38,0)SD R ;SET DR  ARRAY CPT  MODIFIERS  1 AND 2"RT N","DGPTFM 21",39,0)  S DR=DR_"S :'$$CODM^I CPTCOD($P( ^DGCPT(46, D0,0),U),, ,+DGZPRF(D GZP)) Y="" @10"";""RT N","DGPTFM 21",40,0)  S DR=DR_". 02;S:$P(^D GCPT(46,D0 ,0),U,2,3) ?.""^"" Y= ""@10"";.0 3;@10;.2// 1;""RTN"," DGPTFM21", 41,0) Q  ; Exit SDR"R TN","DGPTF M21",42,0) SDR2(DGN)        ;Set  up DR var iable to p rompt for  DGN Codes" RTN","DGPT FM21",43,0 ) S DR=DGN /100_";""R TN","DGPTF M21",44,0)  Q  ;Exit  SDR2"RTN", "DGPTFM21" ,45,0)CHKD GNS(D0,DGN PC)        ;Check to  see if the re are any  more DGN' s to edit  in a Profe ssional se rvice inst ance"RTN", "DGPTFM21" ,46,0) S M ORE=1 ; De fault - mo re DGN's t o process" RTN","DGPT FM21",47,0 ) I DGNPC= 4 S:$P(^DG CPT(46,D0, 0),U,4,7)? ."^" MORE= 0"RTN","DG PTFM21",48 ,0) I DGNP C=5 S:$P(^ DGCPT(46,D 0,0),U,5,7 )?."^" MOR E=0"RTN"," DGPTFM21", 49,0) I DG NPC=6 S:$P (^DGCPT(46 ,D0,0),U,6 ,7)?."^" M ORE=0"RTN" ,"DGPTFM21 ",50,0) I  DGNPC=7 S: $P(^DGCPT( 46,D0,0),U ,7)_$P(^DG CPT(46,D0, 0),U,15,18 )?."^" MOR E=0"RTN"," DGPTFM21", 51,0) I DG NPC=21 S:$ P(^DGCPT(4 6,D0,0),U, 15,18)?."^ " MORE=0"R TN","DGPTF M21",52,0)  I DGNPC=2 2 S:$P(^DG CPT(46,D0, 0),U,16,18 )?."^" MOR E=0"RTN"," DGPTFM21", 53,0) I DG NPC=23 S:$ P(^DGCPT(4 6,D0,0),U, 17,18)?."^ " MORE=0"R TN","DGPTF M21",54,0)  I DGNPC=2 4 S:$P(^DG CPT(46,D0, 0),U,18)?. "^" MORE=0 "RTN","DGP TFM21",55, 0) Q MORE   ;exit w/f lag"RTN"," DGPTFM21", 56,0)SCI(I EN)    Q:' $D(SDCLY)   ;Pass the  ien of th e DGN code  being pro cessed"RTN ","DGPTFM2 1",57,0) N  NODE,I,SC INUM"RTN", "DGPTFM21" ,58,0) ; p wc DG*5.3* 914 RSD SP EC# 2.6.5. 2.5 & 2.6. 5.2.3.1 80 1 & MAS Sc reen Camp  Lejeune (a dded #9 in  loop)"RTN ","DGPTFM2 1",59,0) F  I=2,8,3:1 :7,9 D  ;G o thru the  SCI's"RTN ","DGPTFM2 1",60,0) .  S SCINUM= $S(I=2:I+1 ,((I=3)!(I =4)):I-2,1 :I-1)"RTN" ,"DGPTFM21 ",61,0) .  I $G(SDCLY (SCINUM,IE N))=1 Q  ; If the SCI  has alrea dy been as ked for th e DGN (ien ) don't as k again"RT N","DGPTFM 21",62,0)  . S:I=6 DR =DR_"@30;" "RTN","DGP TFM21",63, 0) . I $D( SDCLY(SCIN UM)) S DR= DR_(I/100) _";",(DA,D )=$G(XREF( IEN)),SDCL Y(SCINUM,I EN)=1 D:I= 2&$O(SDCLY (1))!$D(SD CLY(1))!$D (SDCLY(2))   ;add pro mpt for SC I Y/N"RTN" ,"DGPTFM21 ",64,0) .  . I I<6 S  DR=DR_"S:$ P(^DGICD9( 46.1,DA,0) ,U,2) Y="" @30"";""RT N","DGPTFM 21",65,0)  K I"RTN"," DGPTFM21", 66,0) Q  ; SCI"RTN"," DGPTFM4")0 ^19^B37164 893"RTN"," DGPTFM4",1 ,0)DGPTFM4  ;ALB/MTC/ ADL/PLT -  PTF ENTRY/ EDIT-2 ; 2 6 Dec 2017   1:03 PM" RTN","DGPT FM4",2,0)  ;;5.3;Regi stration;* *114,195,3 97,510,565 ,775,664,7 59,850,884 ,914**;Aug  13, 1993; Build 104" RTN","DGPT FM4",3,0)  ;;Per VA D irective 6 402, this  routine sh ould not b e modified ."RTN","DG PTFM4",4,0 ) ;"RTN"," DGPTFM4",5 ,0) ;;ADL; Update for  CSV Proje ct;;Mar 26 , 2003"RTN ","DGPTFM4 ",6,0) ;"R TN","DGPTF M4",7,0) S  DGZM0=DGZ M0+1"RTN", "DGPTFM4", 8,0)EN ;"R TN","DGPTF M4",9,0) N  M3,M82,DG MPOA"RTN", "DGPTFM4", 10,0) D MO B:'$D(M)"R TN","DGPTF M4",11,0)  S M(DGZM0) =$S($D(M(D GZM0)):M(D GZM0),1:"" ) G NEXM:M (DGZM0)="" "RTN","DGP TFM4",12,0 ) ;CLT, Ch ange +M(DG ZM0) to DG ZM0 on nex t line ;DG *5.3*914"R TN","DGPTF M4",13,0)  S (M3,M(DG ZM0),M1)=$ S($D(^DGPT (PTF,"M",D GZM0,0)):^ DGPT(PTF," M",DGZM0,0 ),1:"")"RT N","DGPTFM 4",14,0) S  M82=$G(^D GPT(PTF,"M ",+M(DGZM0 ),82))"RTN ","DGPTFM4 ",15,0) I  $D(^DGPT(P TF,"M",+M( DGZM0),"P" )) S $P(M( DGZM0),U,2 0)=^("P"), $P(M1,U,20 )=^("P")"R TN","DGPTF M4",16,0)W R S DG300= $S($D(^DGP T(PTF,"M", +M(DGZM0), 300)):^(30 0),1:"")"R TN","DGPTF M4",17,0)  W @IOF,HEA D,?70 S Z= "<501-"_DG ZM0_">" D  Z^DGPTFM I  +M(DGZM0) =1 W !,?62 ,"Discharg e Movement ""RTN","DG PTFM4",18, 0)M S L=+$ P(M1,U,10) ,Y=L D D^D GPTUTL W ! ! S Z=1 D  Z W "Date  of Move: "  S Z=Y,Z1= 20 D Z1 W  "Losing Sp ecialty: " ,$E($S($D( ^DIC(42.4, +$P(M1,U,2 ),0)):$P(^ (0),U,1),1 :""),1,25) "RTN","DGP TFM4",19,0 ) W !,"      Leave da ys: ",$P(M 1,U,3),?44 ,"Pass day s: ",$P(M1 ,U,4)"RTN" ,"DGPTFM4" ,20,0) W ! ,"Treated  for SC Con dition: ", $S($P(M3,U ,18)=1:"Ye s",1:"No") "RTN","DGP TFM4",21,0 ) N NL S N L=0"RTN"," DGPTFM4",2 2,0) I $P( M3,U,31)'= "" W @($S( NL#2:"!",1 :"?37"))," Potentiall y Related  to Combat:  ",$S($P(M 3,U,31)="Y ":"Yes",1: "No") S NL =NL+1"RTN" ,"DGPTFM4" ,23,0) I $ P(M3,U,26) '="" W @($ S(NL#2:"!" ,1:"?37")) ,"Treated  for AO Con dition: ", $S($P(M3,U ,26)="Y":" Yes",1:"No ") S NL=NL +1"RTN","D GPTFM4",24 ,0) I $P(M 3,U,27)'=" " W @($S(N L#2:"!",1: "?37")),"T reated for  IR Condit ion: ",$S( $P(M3,U,27 )="Y":"Yes ",1:"No")  S NL=NL+1" RTN","DGPT FM4",25,0)  I $P(M3,U ,28)'="" W  @($S(NL#2 :"!",1:"?3 7")),"Trea ted for se rvice in S W Asia: ", $S($P(M3,U ,28)="Y":" Yes",1:"No ") S NL=NL +1"RTN","D GPTFM4",26 ,0) I $P(M 3,U,29)'=" " W @($S(N L#2:"!",1: "?37")),"T reated for  MST Condi tion: ",$S ($P(M3,U,2 9)="Y":"Ye s",1:"No")  S NL=NL+1 "RTN","DGP TFM4",27,0 ) K DGNTAR R"RTN","DG PTFM4",28, 0) S DGNTA RR=$$GETCU R^DGNTAPI( DFN,"DGNTA RR")"RTN", "DGPTFM4", 29,0) I $P (M3,U,30)= "",(",3,4, 5,"[(","_$ P($G(DGNTA RR("STAT") ),U)_","))  S $P(M3,U ,30)="N""R TN","DGPTF M4",30,0)  I $P(M3,U, 30)'="" W  @($S(NL#2: "!",1:"?37 ")),"Treat ed for HEA D/NECK CA  Condition:  ",$S($P(M 3,U,30)="Y ":"Yes",1: "No") S NL =NL+1"RTN" ,"DGPTFM4" ,31,0) I $ P(M3,U,32) '="" W @($ S(NL#2:"!" ,1:"?37")) ,"Treated  for Projec t 112/SHAD : ",$S($P( M3,U,32)=" Y":"Yes",1 :"No") S N L=NL+1"RTN ","DGPTFM4 ",32,0) ;  pwc DG*5.3 *914 RSD S PEC# 2.6.6 .2.3 501 S creen Camp  Lejeune,  also added  NL=NL+1 a bove"RTN", "DGPTFM4", 33,0) I $P (M3,U,33)' ="" W @($S (NL#2:"!", 1:"?37")), "Treated f or Camp Le jeune: ",$ S($P(M3,U, 33)="Y":"Y es",1:"No" )"RTN","DG PTFM4",34, 0) K NL"RT N","DGPTFM 4",35,0) N  EFFDATE,I MPDATE"RTN ","DGPTFM4 ",36,0) D  EFFDATE^DG PTIC10(PTF )"RTN","DG PTFM4",37, 0) W !! S  Z=2 D Z W  "           DX: ",$$G ETLABEL^DG PTIC10(EFF DATE,"D")" RTN","DGPT FM4",38,0)  ;F I=1:1: 11 S L=$P( M1,U,I+4)  I L'=""&(I '=6) D"RTN ","DGPTFM4 ",39,0) D  PTFICD^DGP TFUT(501,P TF,+M(DGZM 0),.DGX501 )"RTN","DG PTFM4",40, 0) S I=0 F   S I=$O(D GX501(I))  QUIT:'I  S  L=DGX501( I) D"RTN", "DGPTFM4", 41,0) . S  DGMPOA=$P( L,U,2)"RTN ","DGPTFM4 ",42,0) .  S DGPTTMP= $$ICDDATA^ ICDXCODE(" DIAG",+L,E FFDATE)"RT N","DGPTFM 4",43,0) .  D WRITECO D^DGPTIC10 ("DIAG",+L ,EFFDATE,2 ,1,15)"RTN ","DGPTFM4 ",44,0) .  I $P(DGPTT MP,U,20)=3 0 W:$X>73  !,"             " W "  (POA=",$S (DGMPOA]"" :DGMPOA,1: "''"),")"" RTN","DGPT FM4",45,0)  . W $S(+D GPTTMP<1!( '$P(DGPTTM P,U,10)):" *",1:"")"R TN","DGPTF M4",46,0)  . I $Y>(IO SL-4) D PG BR W @IOF, HEAD,?72 S  Z="<501-" _DGZM0_">"  D Z^DGPTF M W !"RTN" ,"DGPTFM4" ,47,0) . Q UIT"RTN"," DGPTFM4",4 8,0) K DGX 501"RTN"," DGPTFM4",4 9,0) D PRN 2^DGPTFM8: DG300]"""R TN","DGPTF M4",50,0)  ;"RTN","DG PTFM4",51, 0) I $P(M1 ,U,20) S D RG=$P(M1,U ,20) W:DRG =998!(DRG= 999)!((DRG =468!(DRG= 469)!(DRG= 470))&(+$P ($G(M1),U, 10)<307100 1)) *7 W ! !?14,"TRAN SFER DRG:  ",DRG D"RT N","DGPTFM 4",52,0) .  N DXD,DGD X"RTN","DG PTFM4",53, 0) . S DXD =$$DRGD^IC DGTDRG(DRG ,"DGDX",,$ P(M1,U,10) ),DGDS=0"R TN","DGPTF M4",54,0)  . F  S DGD S=$O(DGDX( DGDS)) Q:' +DGDS  Q:D GDX(DGDS)= " "  W !,D GDX(DGDS)" RTN","DGPT FM4",55,0) JUMP K DG3 00 F I=$Y: 1:21 W !"R TN","DGPTF M4",56,0)X  S DGNUM=$ S($D(M(DGZ M0+1)):501 _"-"_(DGZM 0+1),1:"MA S") G 501^ DGPTFJC:DG ST"RTN","D GPTFM4",57 ,0) W "Ent er <RET> t o continue , 1-2 to e dit,",!,"' M' ",$S(DG PTFE:" to  add a pati ent moveme nt",1:"to  edit Treat . Specialt y"),", '^N ' for scre en N, or ' ^' to abor t:<",DGNUM ,">// " R  X:DTIME"RT N","DGPTFM 4",58,0) K  DGNUM G Q :X="^",NEX M:X="",^DG PTFJ:X?1"^ ".E,M^DGPT FM1:X="M"! (X="m")"RT N","DGPTFM 4",59,0)X1  I X'=1,X' =2,X'="1-2 " G PR"RTN ","DGPTFM4 ",60,0) S  DGCODSYS=$ $CODESYS^D GPTIC10(PT F)"RTN","D GPTFM4",61 ,0) S DR=$ S(DGPTFE:" [DG501F-10 D]",1:"[DG 501-10D]")  I DGCODSY S="ICD9" S  DR=$S(DGP TFE:"[DG50 1F]",1:"[D G501]")"RT N","DGPTFM 4",62,0) S  DGJUMP=X, DIE="^DGPT (",(DA,DGP TF)=PTF,DG MOV=+M(DGZ M0) D ^DIE "RTN","DGP TFM4",63,0 ) I DR'["- 10D" K DR, DA,DIE,DIC  S DR="" X :(+M(DGZM0 )=1) "S J= ^DGPT(PTF, ""M"",1,0)  F I=11:1: 15 I $P(J, U,I) S DR= DR_I_"";"" " I DR'=""  D"RTN","D GPTFM4",64 ,0) . S DG JUMP=X,DIE ="^DGPT("_ DGPTF_","" M"",",(DA( 1),DGPTF)= PTF,(DA,DG MOV)=+M(DG ZM0)"RTN", "DGPTFM4", 65,0) . D  ^DIE"RTN", "DGPTFM4", 66,0) . QU IT"RTN","D GPTFM4",67 ,0) K M,DR ,DIE D CHK 501^DGPTSC AN K DGPTF ,DGMOV"RTN ","DGPTFM4 ",68,0) ;  Determine  if NTR HIS TORY (#28. 11) filer  is called  if questio n for"RTN" ,"DGPTFM4" ,69,0) ;   'Treated f or Head/Ne ck CA Cond ition:' is  answered  YES."RTN", "DGPTFM4", 70,0) ; On ly a NTR s creening s tatus of 3 =PENDING D IAGNOSIS g ets Filed. "RTN","DGP TFM4",71,0 ) I $P($G( M3),U,30)= "Y",$P($G( DGNTARR("S TAT")),U)= 3 D"RTN"," DGPTFM4",7 2,0) . S D GNTARR=$$F ILEHNC^DGN TAPI1(DFN) "RTN","DGP TFM4",73,0 ) . QUIT"R TN","DGPTF M4",74,0)  K DGNTARR" RTN","DGPT FM4",75,0)  ;- update  MT indica tor after  edit movem ent"RTN"," DGPTFM4",7 6,0) N DGP MCA,DGPMAN  D PM^DGPT UTL"RTN"," DGPTFM4",7 7,0) I '$G (DGADM) S  DGADM=+^DG PT(PTF,0)" RTN","DGPT FM4",78,0)  D MT^DGPT UTL"RTN"," DGPTFM4",7 9,0) G EN" RTN","DGPT FM4",80,0)  ;"RTN","D GPTFM4",81 ,0)PR W !, "Enter '^'  to stop t he display  and edit  of data",! ,"'^N' to  jump to sc reen #N (a ppears in  upper righ t of scree n '<N>'",! ,"<RET> to  continue  on to the  next scree n or 1-2 t o edit:""R TN","DGPTF M4",82,0)  W !?10,"1- ",$S(DGPTF E:"Date of  movement,  Losing Sp ecialty, " ,1:""),"Le ave and Pa ss days",! ?10,"2-ICD  DIAGNOSIS  CODES""RT N","DGPTFM 4",83,0) W  !,"You ma y also ent er 1-2",!" RTN","DGPT FM4",84,0)  R !!,"Ent er <RET>:  ",X:DTIME  G WR"RTN", "DGPTFM4", 85,0) Q"RT N","DGPTFM 4",86,0)NE XM S DGZM0 =DGZM0+1 G  ^DGPTFM:' $D(M(DGZM0 )),EN"RTN" ,"DGPTFM4" ,87,0) ;"R TN","DGPTF M4",88,0)A DD ;add mo vement rec ord of fee  basis pat ent"RTN"," DGPTFM4",8 9,0) S DGZ M0=$S($D(D GZM0):DGZM 0+1,1:0) S  L=$S($D(^ DGPT(PTF," M",0)):^(0 ),1:"^45.0 2DA^^"),L1 =$P(L,U,3)  F I=1:1 Q :'$D(^DGPT (PTF,"M",L 1+I))"RTN" ,"DGPTFM4" ,90,0) S D A(1)=PTF,D IC="^DGPT( "_DA(1)_", ""M"",",X= L1+I,DIC(0 )="LMZQE"  D ^DIC K D IC,DIE G ^ DGPTFM:Y'> 0"RTN","DG PTFM4",91, 0) S M(DGZ M0)=L1+I S  X="1-2" G  X1"RTN"," DGPTFM4",9 2,0) Q"RTN ","DGPTFM4 ",93,0)MOB  S I=0 K M ,M1,M2 S M 2=0 F I1=1 :1 S I=$O( ^DGPT(PTF, "M",I)) Q: 'I  S M(I1 )=^(I,0)"R TN","DGPTF M4",94,0)  S PM=I1-1  D ORDER^DG PTF Q"RTN" ,"DGPTFM4" ,95,0)Q G  Q^DGPTF"RT N","DGPTFM 4",96,0)Z  I 'DGN S Z =$S(IOST=" C-QUME"&($ L(DGVI)'=2 ):Z,1:"["_ Z_"]") W @ DGVI,Z,@DG VO"RTN","D GPTFM4",97 ,0) E  W "    ""RTN", "DGPTFM4", 98,0) Q"RT N","DGPTFM 4",99,0)Z1  F I=1:1:( Z1-$L(Z))  S Z=Z_" "" RTN","DGPT FM4",100,0 ) W Z"RTN" ,"DGPTFM4" ,101,0) Q" RTN","DGPT FM4",102,0 )R ;DELETE  PROCEDURE  RECORD"RT N","DGPTFM 4",103,0)  I '$D(^DGP T(PTF,"P") ) G NOPROC "RTN","DGP TFM4",104, 0) I $O(^D GPT(PTF,"P ",0))']""  G NOPROC"R TN","DGPTF M4",105,0)  S DGPNUM= "" F DGPRO C=0:0 S DG PROC=$O(P( DGPROC)) Q :'DGPROC   S:$D(P(DGP ROC,1)) DG PNUM=DGPNU M_","_DGPR OC"RTN","D GPTFM4",10 6,0) S DGP NUM=DGPNUM _",""RTN", "DGPTFM4", 107,0)ASKP RO W !!,"D elete proc edure reco rd <",$P(D GPNUM,",", 2,99),"> :  " R DGPRO C:DTIME I  DGPROC[U!( DGPROC="")  K DGPNUM, DGPROC G ^ DGPTFM"RTN ","DGPTFM4 ",108,0) I  DGPNUM'[( ","_DGPROC _",") W !! ,"Enter th e record #  to delete  from the  PTF file < ",$P(DGPNU M,",",2,99 ),">",! G  ASKPRO"RTN ","DGPTFM4 ",109,0) K  DA N DGJ" RTN","DGPT FM4",110,0 ) F DGJ=1: 1 S DA=+$P (DGPROC,", ",DGJ) Q:' DA  S DA=$ S($D(P(DA, 1)):+P(DA, 1),1:0) I  DA S DA(1) =PTF,DIK=" ^DGPT("_PT F_",""P"", " D ^DIK K  DA W "    ",$P(DGPRO C,",",DGJ) ,"-DELETED ***" H:'$P (DGPROC,", ",DGJ+1) 2 "RTN","DGP TFM4",111, 0) K DIK,D A,DGPROC,D GPNUM G ^D GPTFM"RTN" ,"DGPTFM4" ,112,0)NOP ROC W !!,* 7,"No proc edures to  delete",!  H 3 G ^DGP TFM"RTN"," DGPTFM4",1 13,0) Q"RT N","DGPTFM 4",114,0)  ;"RTN","DG PTFM4",115 ,0)PGBR N  DIR,X,Y S  DIR(0)="E" ,DIR("A")= "Enter RET URN to con tinue" D ^ DIR QUIT"R TN","DGPTF M4",116,0)  ;"RTN","D GPTFMO")0^ 20^B451598 24"RTN","D GPTFMO",1, 0)DGPTFMO  ;ALB/JDS/A DL,HIOFO/F T - DGPTF  PRINT TEMP LATE ;10/1 5/14 2:25p m"RTN","DG PTFMO",2,0 ) ;;5.3;Re gistration ;**195,397 ,510,590,5 94,606,683 ,729,664,8 50,884,914 **;Aug 13,  1993;Buil d 104"RTN" ,"DGPTFMO" ,3,0) ;;AD L;Updated  for CSV Pr oject;;Mar  4, 2003"R TN","DGPTF MO",4,0) ; "RTN","DGP TFMO",5,0)  ; ICDEX A PIs - #574 7"RTN","DG PTFMO",6,0 ) ; ICDGTD RG APIs -  #4052"RTN" ,"DGPTFMO" ,7,0) ; IC DXCODE API s - #5699" RTN","DGPT FMO",8,0)  ;"RTN","DG PTFMO",9,0 ) ;;ADL;Up dated for  CSV Projec t;;Mar 4,  2003"RTN", "DGPTFMO", 10,0) ;FOR  PTF REPOR T CALLED F ROM PRINT  TEMPLATE D GPTF"RTN", "DGPTFMO", 11,0) ;"RT N","DGPTFM O",12,0)EN  ;called f rom print  template D GPT CENSUS  INQUIRY"R TN","DGPTF MO",13,0)  K A,B,AD,A DA,DGDD,DG DDPTR,DGLO OP,DGFC,HE AD,DGPTFE, DGST,DGN,T ,T82,DGM82 ,EFFDATE,I MPDATE,DGP TDAT"RTN", "DGPTFMO", 14,0) F DG LOOP=4:1:7  D  ;get t he set of  codes for  fields 4,5 ,6, & 7 in  45.01 (40 1 data - S urgery)"RT N","DGPTFM O",15,0) . K DGERROR, DGRESULT"R TN","DGPTF MO",16,0)  .S DGDDPTR (DGLOOP)=" ""RTN","DG PTFMO",17, 0) .D FIEL D^DID(45.0 1,DGLOOP,, "POINTER", "DGRESULT" ,"DGERROR" )"RTN","DG PTFMO",18, 0) .I '$D( DGERROR) S  DGDDPTR(D GLOOP)=$G( DGRESULT(" POINTER")) "RTN","DGP TFMO",19,0 ) K DGERRO R,DGRESULT "RTN","DGP TFMO",20,0 ) ;"RTN"," DGPTFMO",2 1,0) F I=0 :0 S I=$O( ^DGPT(D0," M",I)) Q:I '>0  I $D( ^(I,0)) S  J=+$P(^(0) ,U,10) S:' J J=999999 999 S:$D(T (J)) J=J+. 01*I S T(J )=I"RTN"," DGPTFMO",2 2,0) F I=0 :0 S I=$O( T(I)) Q:I' >0  S DGM= $S($D(^DGP T(D0,"M",T (I),0)):^( 0),1:"") D :DGM]"" WR ITE"RTN"," DGPTFMO",2 3,0) ;"RTN ","DGPTFMO ",24,0) K  T F I=0:0  S I=$O(^DG PT(D0,"S", I)) Q:I'>0   D SUR"RT N","DGPTFM O",25,0) S  DGOP1=$S( $D(^DGPT(D 0,"401P")) :^("401P") ,1:"")"RTN ","DGPTFMO ",26,0) I  DGOP1]"" D  HEAD:$Y>( IOSL-10) G  Q:'DN D P ROC"RTN"," DGPTFMO",2 7,0) I $D( ^DGPT(D0," P")) D HEA D:$Y>(IOSL -10) G Q:' DN F I=0:0  S I=$O(^D GPT(D0,"P" ,I)) Q:I'> 0  S DG601 =^DGPT(D0, "P",I,0),Y =+DG601 D  D^DGPTUTL  W !!?5,"Pr ocedure Da te: ",Y,$$ GETLABEL^D GPTIC10(EF FDATE,"P")  D 601"RTN ","DGPTFMO ",28,0) S  DGPT=$G(^D GPT(D0,70) ) I DGPT]" " G Q:'DN  D DXLS"RTN ","DGPTFMO ",29,0) K  %,DGL,DGM, DGPT,DGOP, DGOP1,DGF, DGP,DXLS,D GICD,L1,S1 ,T,J,K,DGP R,DGN,AGE, B,DA,DAM,D FN,DGST,DO B,DP,DRG,E XP,NO,P,PT F,DGPTFE,S D1,SEX,TAC ,TRS,DGDS, DGTD,DGPRO C,DG601,DG PTDAT"RTN" ,"DGPTFMO" ,30,0) W ! "RTN","DGP TFMO",31,0 ) K T82,DG M82,DGMPOA ,DGLOOP"RT N","DGPTFM O",32,0) Q "RTN","DGP TFMO",33,0 )WRITE D H EAD:$Y>(IO SL-12) G Q :'DN S Y=$ P(DGM,U,10 ),DGL=+$P( DGM,U,2),D GL=$S($D(^ DIC(42.4,D GL,0)):^(0 ),1:""),DG L=$P(DGL,U ,1) D D^DG PTUTL"RTN" ,"DGPTFMO" ,34,0) ; I CD-10 CALL S"RTN","DG PTFMO",35, 0) D EFFDA TE^DGPTIC1 0(D0)"RTN" ,"DGPTFMO" ,36,0) ;"R TN","DGPTF MO",37,0)  W !!,"Move ment Date:  ",Y,?40," Losing Spe cialty: ", $E(DGL,1,2 2),!,"Leav e Days: ", $P(DGM,U,3 ),?40,"Pas s Days: ", $P(DGM,U,4 )"RTN","DG PTFMO",38, 0) W !,"Tr eated for  SC conditi on: ",$S($ P(DGM,U,18 )=1:"Yes", 1:"No")"RT N","DGPTFM O",39,0) W :$P(DGM,U, 31)'="" !, "Potential ly Related  to Combat : ",$S($P( DGM,U,31)= "Y":"Yes", 1:"No")"RT N","DGPTFM O",40,0) W :$P(DGM,U, 26)'="" !, "Treated f or AO cond ition: ",$ S($P(DGM,U ,26)="Y":" Yes",1:"No ")"RTN","D GPTFMO",41 ,0) W:$P(D GM,U,27)'= "" !,"Trea ted for IR  condition : ",$S($P( DGM,U,27)= "Y":"Yes", 1:"No")"RT N","DGPTFM O",42,0) W :$P(DGM,U, 28)'="" !, "Treated f or service  in SW Asi a: ",$S($P (DGM,U,28) ="Y":"Yes" ,1:"No")"R TN","DGPTF MO",43,0)  W:$P(DGM,U ,29)'="" ! ,"Treated  for MST co ndition: " ,$S($P(DGM ,U,29)="Y" :"Yes",$P( DGM,U,29)= "N":"No",1 :"Declined  to answer ") ; added  6/17/98 f or MST enh ancement"R TN","DGPTF MO",44,0)  W:$P(DGM,U ,30)'="" ! ,"Treated  for HEAD/N ECK CA con dition: ", $S($P(DGM, U,30)="Y": "Yes",1:"N o")"RTN"," DGPTFMO",4 5,0) W:$P( DGM,U,32)' ="" !,"Tre ated for S HAD Condit ion: ",$S( $P(DGM,U,3 2)="Y":"Ye s",1:"No") "RTN","DGP TFMO",46,0 ) ; pwc DG *5.3*914 R SD SPEC# 2 .6.5.2.4 5 01 Screen  Camp Lejeu ne"RTN","D GPTFMO",47 ,0) W:$P(D GM,U,33)'= "" !,"Trea ted for Ca mp Lejeune  Condition : ",$S($P( DGM,U,33)= "Y":"Yes", 1:"No")"RT N","DGPTFM O",48,0) W :T(I)=1 !, "Discharge  ""RTN","D GPTFMO",49 ,0) S DGF= "",J=0 K D G501"RTN", "DGPTFMO", 50,0) D PT FICD^DGPTF UT(501,D0, T(I),.DG50 1,1)"RTN", "DGPTFMO", 51,0) F  S  J=$O(DG50 1(J)) Q:'J   D"RTN"," DGPTFMO",5 2,0) . S D GMPOA=$P(D G501(J),U, 2) ;get PO A code"RTN ","DGPTFMO ",53,0) .  S DGPTTMP= $$ICDDATA^ ICDXCODE(" DIAG",+$P( DG501(J),U ,1),EFFDAT E)"RTN","D GPTFMO",54 ,0) . W:DG F="" !!?5, "DX: ",$$G ETLABEL^DG PTIC10(EFF DATE,"D")" RTN","DGPT FMO",55,0)  . D WRITE COD^DGPTIC 10("DIAG", +$P(DG501( J),U,1),EF FDATE,2,1, 8)"RTN","D GPTFMO",56 ,0) . I $P (DGPTTMP,U ,20)=30 W: $X>73 !,"              " W " (PO A=",$S(DGM POA]"":DGM POA,1:"''" ),")""RTN" ,"DGPTFMO" ,57,0) . W  $S(+DGPTT MP<1!('$P( DGPTTMP,U, 10)):"*",1 :"")"RTN", "DGPTFMO", 58,0) . S  DGF=1"RTN" ,"DGPTFMO" ,59,0) K D G501"RTN", "DGPTFMO", 60,0) ;--  display ex panded cod es "RTN"," DGPTFMO",6 1,0) S DG3 00=$S($D(^ DGPT(D0,"M ",T(I),300 )):^(300), 1:"") I DG 300]"" D H EAD:$Y>(IO SL-6) D PR N2^DGPTFM8  W !"RTN", "DGPTFMO", 62,0) K DG 300"RTN"," DGPTFMO",6 3,0) ;Disp lay TRANSF ER DRG wit h descript ion"RTN"," DGPTFMO",6 4,0) Q:'$D (^DGPT(D0, "M",T(I)," P"))  S DG TD=+^("P")  Q:$P($$CO DEC^ICDEX( 80,DGTD),U ,1)="-1"   W !?3,"TRA NSFER DRG:  ",DGTD,"  - ""RTN"," DGPTFMO",6 5,0) N DXD ,DGDX"RTN" ,"DGPTFMO" ,66,0) S D XD=$$DRGD^ ICDGTDRG(D GTD,"DGDX" ,,$$GETDAT E^ICDGTDRG (D0)),DGDS =0"RTN","D GPTFMO",67 ,0) F  S D GDS=$O(DGD X(DGDS)) Q :'+DGDS  Q :DGDX(DGDS )=" "  W ! ,DGDX(DGDS )"RTN","DG PTFMO",68, 0) Q"RTN", "DGPTFMO", 69,0)HEAD  I $E(IOST, 1)="C" W * 7 R X:DTIM E I X=U S  DN=0 Q"RTN ","DGPTFMO ",70,0) S  DC=DC+1 W  @IOF,! X:$ D(^UTILITY ($J,2)) ^( 2) W ! F K =1:1:IOM W  "_""RTN", "DGPTFMO", 71,0) W !, "("_$P(^DP T(+^DGPT(D 0,0),0),U, 1)_")",!"R TN","DGPTF MO",72,0)  Q"RTN","DG PTFMO",73, 0)SUR ;"RT N","DGPTFM O",74,0) D  HEAD:$Y>( IOSL-7) G  Q:'DN S S1 =^DGPT(D0, "S",I,0),Y =+S1 D D^D GPTUTL W ! !,"   Date  of Surg:  ",Y,?45,"C hief Surg:  ""RTN","D GPTFMO",75 ,0) S L="; "_DGDDPTR( 4),L1=";"_ $P(S1,U,4) _":" W $P( $P(L,L1,2) ,";",1)"RT N","DGPTFM O",76,0) W  !,"    An esth Tech:  " S L=";" _DGDDPTR(6 ),L1=";"_$ P(S1,U,6)_ ":" W $P($ P(L,L1,2), ";",1),?45 ,"First As st: ""RTN" ,"DGPTFMO" ,77,0) S L =";"_DGDDP TR(5),L1=" ;"_$P(S1,U ,5)_":" W  $P($P(L,L1 ,2),";",1) "RTN","DGP TFMO",78,0 ) W !,"  S ource of p ay: " S L= ";"_DGDDPT R(7),L1="; "_$P(S1,U, 7)_":" W $ P($P(L,L1, 2),";",1)" RTN","DGPT FMO",79,0)  W ?46,"Su rg spec: " ,$S($D(^DI C(45.3,+$P (S1,U,3),0 )):$P(^(0) ,U,2),1:"" )"RTN","DG PTFMO",80, 0) W !!,?5 ,"Surg/pro : ",$$GETL ABEL^DGPTI C10(EFFDAT E,"P"),!?7 "RTN","DGP TFMO",81,0 ) S K=0 K  DG401"RTN" ,"DGPTFMO" ,82,0) D P TFICD^DGPT FUT(401,D0 ,I,.DG401, 1)"RTN","D GPTFMO",83 ,0) F  S K =$O(DG401( K)) Q:'K   D"RTN","DG PTFMO",84, 0) . S L=$ P(DG401(K) ,U,1),DGPT TMP="""RTN ","DGPTFMO ",85,0) .  I L'="" S  DGPTTMP=$$ ICDDATA^IC DXCODE("PR OC",+L,EFF DATE) D"RT N","DGPTFM O",86,0) . . D WRITEC OD^DGPTIC1 0("PROC",+ L,EFFDATE, 2,1,8)"RTN ","DGPTFMO ",87,0) ..  W $S(+DGP TTMP<1!('$ P(DGPTTMP, U,10)):"*" ,1:"")"RTN ","DGPTFMO ",88,0) K  DG401"RTN" ,"DGPTFMO" ,89,0) ;--  display e xpanded co des"RTN"," DGPTFMO",9 0,0) S DG3 00=$S($D(^ DGPT(D0,"S ",I,300)): ^(300),1:" ") I DG300 ]"" D PRN3 ^DGPTFM8"R TN","DGPTF MO",91,0)  K DG300"RT N","DGPTFM O",92,0) Q "RTN","DGP TFMO",93,0 )PROC ;"RT N","DGPTFM O",94,0) S  DGF="" F  I=1:1:5 D: $P(DGOP1,U ,I)'="""RT N","DGPTFM O",95,0) .  S DGPTTMP =$$ICDDATA ^ICDXCODE( "PROC",+$P (DGOP1,U,I ),EFFDATE) "RTN","DGP TFMO",96,0 ) . W:'DGF  !!?5,"Pro cedure: ", $$GETLABEL ^DGPTIC10( EFFDATE,"P ") S DGF=1 "RTN","DGP TFMO",97,0 ) . D WRIT ECOD^DGPTI C10("PROC" ,+$P(DGOP1 ,U,I),EFFD ATE,2,1,8) "RTN","DGP TFMO",98,0 ) . W $S(+ DGPTTMP<1! ('$P(DGPTT MP,U,10)): "*",1:"")" RTN","DGPT FMO",99,0)  Q"RTN","D GPTFMO",10 0,0)601 ;p rint the p rocedures/ dates from  the 601 p rocedure m ultiple (e ff. 10/1/8 7)"RTN","D GPTFMO",10 1,0) K DG6 01 S J=0"R TN","DGPTF MO",102,0)  D PTFICD^ DGPTFUT(60 1,D0,I,.DG 601,1)"RTN ","DGPTFMO ",103,0) F   S J=$O(D G601(J)) Q :'J  D"RTN ","DGPTFMO ",104,0) .  S DGPTTMP =$$ICDDATA ^ICDXCODE( "PROC",+$P (DG601(J), U,1),EFFDA TE)"RTN"," DGPTFMO",1 05,0) . D  WRITECOD^D GPTIC10("P ROC",+$P(D G601(J),U, 1),EFFDATE ,2,1,8)"RT N","DGPTFM O",106,0)  . W $S(+DG PTTMP<1!(' $P(DGPTTMP ,U,10)):"* ",1:"")"RT N","DGPTFM O",107,0)  K DG601"RT N","DGPTFM O",108,0)  Q"RTN","DG PTFMO",109 ,0)DXLS D  HEAD:$Y>(I OSL-16)"RT N","DGPTFM O",110,0)  S DGPOA1=$ P($G(^DGPT (D0,82)),U ,1) ;POA f or princip al DX"RTN" ,"DGPTFMO" ,111,0) I  +$P(DGPT,U ,10) D"RTN ","DGPTFMO ",112,0) .  S DGPTTMP =$$ICDDATA ^ICDXCODE( "DIAG",+$P (DGPT,U,10 ),EFFDATE) ,DXLS=$S(+ DGPTTMP>0: $P(DGPTTMP ,U,2,99),1 :"")"RTN", "DGPTFMO", 113,0) . W  !!?5,"PRI NCIPAL DIA GNOSIS: ", $$GETLABEL ^DGPTIC10( EFFDATE,"D ")"RTN","D GPTFMO",11 4,0) . D W RITECOD^DG PTIC10("DI AG",+$P(DG PT,U,10),E FFDATE,2,1 ,8)"RTN"," DGPTFMO",1 15,0) . W  $S(+DGPTTM P<1!('$P(D GPTTMP,U,1 0)):"*",1: "")"RTN"," DGPTFMO",1 16,0) . Q: $P(DGPTTMP ,U,20)'=30   ;not an  ICD10 DX"R TN","DGPTF MO",117,0)  . W " ["_ $S(DGPOA1] "":DGPOA1, 1:" ")_"]"  ;show POA  value"RTN ","DGPTFMO ",118,0) ; "RTN","DGP TFMO",119, 0) I +$P(D GPT,U,11)  D"RTN","DG PTFMO",120 ,0) . S DG PTTMP=$$IC DDATA^ICDX CODE("DIAG ",+$P(DGPT ,U,11),EFF DATE)"RTN" ,"DGPTFMO" ,121,0) .  D WRITECOD ^DGPTIC10( "DIAG",+$P (DGPT,U,11 ),EFFDATE, 2,1,8)"RTN ","DGPTFMO ",122,0) .  W $S(+DGP TTMP<1!('$ P(DGPTTMP, U,10)):"*" ,1:"")"RTN ","DGPTFMO ",123,0) .  Q:$P(DGPT TMP,U,20)' =30  ;not  an ICD10 D X"RTN","DG PTFMO",124 ,0) . W "  ["_$S(DGPO A1]"":DGPO A1,1:" ")_ "]" ;show  POA value.  there sho uldn't be  one for ol d records" RTN","DGPT FMO",125,0 ) K DG701, DGPOA1 S K =0"RTN","D GPTFMO",12 6,0) D PTF ICD^DGPTFU T(701,D0,, .DG701,1)" RTN","DGPT FMO",127,0 ) F  S K=$ O(DG701(K) ) Q:'K  D: $P(DG701(K ),U,1)>0 D SP"RTN","D GPTFMO",12 8,0) K DG7 01"RTN","D GPTFMO",12 9,0) ;-- d isplay exp anded code  informati on"RTN","D GPTFMO",13 0,0) S DG3 00=$S($D(^ DGPT(D0,30 0)):^(300) ,1:"") D:D G300]"" PR N2^DGPTFM8  K DG300"R TN","DGPTF MO",131,0)  D EN2^DGP TF4 ;calls  ^DGPTFD t o get DX/O P codes an d then cal ls DGPTICD  to calcul ate & stor e DRG valu e in PTF C LOSE OUT ( #45.84) fi le."RTN"," DGPTFMO",1 32,0) Q"RT N","DGPTFM O",133,0)Q  Q"RTN","D GPTFMO",13 4,0)Q1 K ^ UTILITY(U, $J),DG1"RT N","DGPTFM O",135,0)  Q"RTN","DG PTFMO",136 ,0)DT I Y  W $P("JAN^ FEB^MAR^AP R^MAY^JUN^ JUL^AUG^SE P^OCT^NOV^ DEC",U,$E( Y,4,5)),"  " W:Y#100  $J(Y#100\1 ,2),"," W  Y\10000+17 00 W:Y#1 "   ",$E(Y_0 ,9,10),":" ,$E(Y_"000 ",11,12)"R TN","DGPTF MO",137,0)  Q"RTN","D GPTFMO",13 8,0)DSP ;" RTN","DGPT FMO",139,0 ) S J=$$IC DDATA^ICDX CODE("DIAG ",+$P(DG70 1(K),U,1), EFFDATE) D "RTN","DGP TFMO",140, 0) . D WRI TECOD^DGPT IC10("DIAG ",+$P(DG70 1(K),U,1), EFFDATE,2, 1,8)"RTN", "DGPTFMO", 141,0) . W  $S(+J<1!( '$P(J,U,10 )):"*",1:" ")"RTN","D GPTFMO",14 2,0) . Q:$ P(J,U,20)' =30  ;not  an ICD-10  DX"RTN","D GPTFMO",14 3,0) . W "  ["_$S($P( DG701(K),U ,2)]"":$P( DG701(K),U ,2),1:" ") _"]""RTN", "DGPTFMO", 144,0) Q"R TN","DGPTF TR")0^59^B 55556979"R TN","DGPTF TR",1,0)DG PTFTR ;ALB /JDS,HIOFO /FT - TRAN SMISSION O F PTF ;8/2 0/15 3:47p m"RTN","DG PTFTR",2,0 ) ;;5.3;Re gistration ;**37,415, 530,601,61 4,645,787, 850,884,91 4**;Aug 13 , 1993;Bui ld 104"RTN ","DGPTFTR ",3,0) ;"R TN","DGPTF TR",4,0) ;  VA(200) -  #10060"RT N","DGPTFT R",5,0) ;  XMB(3.9) -  #10113"RT N","DGPTFT R",6,0) ;  VATRAN - # 1011"RTN", "DGPTFTR", 7,0) ; XLF DT - #1010 3"RTN","DG PTFTR",8,0 ) ; XMA21  - #10067"R TN","DGPTF TR",9,0) ;  XMD - #10 070"RTN"," DGPTFTR",1 0,0) ; %ZT LOAD - #10 063"RTN"," DGPTFTR",1 1,0) ;"RTN ","DGPTFTR ",12,0)ENN  ;PTF Tran smission [ DG PTF TRA NSMISSION  DNS  S]"RT N","DGPTFT R",13,0) L  +^DGP(45. 83):$G(DIL OCKTM,5) I  '$T W !," Another us er is alre ady transm itting. Pl ease try a gain later ." Q  ;45. 83 is PTF  RELEASE"RT N","DGPTFT R",14,0) D  CEN^DGPTU TL ;find c urrent cen sus (file  45.86). re turns DGCN =ien,DGCN0 =zero node "RTN","DGP TFTR",15,0 ) I '$D(DG RTY) S Y=1  D RTY^DGP TUTL ;dete rmine reco rd type. I f Y=1, the n DGRTY=1, DGRTY0="PT F". If Y=2 , then DGR TY=2,DGRTY 0="CENSUS" "RTN","DGP TFTR",16,0 ) D FDT^DG PTUTL S DG FMTDT=Y ;s ets Y=2901 000"RTN"," DGPTFTR",1 7,0) ;"RTN ","DGPTFTR ",18,0)EN5  ;select a  PTF RELEA SE date or  range"RTN ","DGPTFTR ",19,0) K  DIC S DIC= 45.83,DIC( 0)="AZEQ", DIC("A")=" Enter Star t Date: "" RTN","DGPT FTR",20,0)  S DIC("S" )="I $O(^D GP(45.83,+ Y,""P"",0) ) F DGX=0: 0 S DGX=$O (^DGP(45.8 3,+Y,""P"" ,DGX)) Q:' DGX  I '$P (^DGP(45.8 3,+Y,""P"" ,DGX,0),U, 2),$D(^DGP T(DGX,0)), $D(^(70)), +^(70)>290 1000,$P(^( 0),U,11)=+ DGRTY Q""R TN","DGPTF TR",21,0)  S D="ANT"  D IX^DIC G  ENQ1:X["^ "!(X="")"R TN","DGPTF TR",22,0)  I Y'>0 W ! ,"There ar e no "_$S( $G(DGRTY)= 2:"CENSUS" ,1:"PTF")_ " records  in this da te range t o transmit ." G EN5"R TN","DGPTF TR",23,0)  S DGSD=+Y( 0),DIC(0)= "EAZQ",DIC ("S")="I Y '<DGSD"_"  "_DIC("S") ,DIC("A")= "Enter Thr ough Date:  TODAY//   ",D="ANT"  D IX^DIC K  DIC,D"RTN ","DGPTFTR ",24,0) ;" RTN","DGPT FTR",25,0)  G ENQ1:X[ "^" S DGED =$S(Y>0:+Y (0),1:DT)" RTN","DGPT FTR",26,0)  ;call VAT RAN to get  transmiss ion variab les "RTN", "DGPTFTR", 27,0) ;PTF 125 should  be an ent ry in TRAN SMISSION R OUTERS (#4 07.7)"RTN" ,"DGPTFTR" ,28,0) ;VA TERR retur ns null if  no error.  1 or 2 or  3 if can' t process" RTN","DGPT FTR",29,0)  ;returns  VAT array.  VAT(1) &  VAT(2) are  receiving  users"RTN ","DGPTFTR ",30,0) ;V AT("F")=me ssage leng th (fixed  record), V AT("V")=me ssage leng th (variab le record) "RTN","DGP TFTR",31,0 ) S VATNAM E="PTF125"  D ^VATRAN  I VATERR  K VATNAME, VATERR,VAT  L -^DGP(4 5.83) G EN Q"RTN","DG PTFTR",32, 0) S DGFMT =2 D SCAN  G:DGOUTX E NQ1"RTN"," DGPTFTR",3 3,0)ENQ D  SCAN^DGPTF TR3 ;loops  thru 45.8 3 and upda tes transm ission dat e"RTN","DG PTFTR",34, 0)ENQ1 L - ^DGP(45.83 ) K DGACNT ,DGXM,XMDU N,XMY,DGOU TX,DGSTCNT ,DIC,DGX,D GRTY,DGRTY 0,DGCN,DGC N0,DGPTFMT ,DGFMT,DGF MTDT,DGLOG IC,VAT,VAT ERR,VATNAM E,DGSD,DGE D,DGPTSLF" RTN","DGPT FTR",35,0)  Q"RTN","D GPTFTR",36 ,0) ;"RTN" ,"DGPTFTR" ,37,0)SCAN  K DGERR"R TN","DGPTF TR",38,0)  N DGY S DG Y=$G(Y) D  FMT^DGPTUT L S Y=$G(D GY) ;sets  DGPTFMT=1,  2 (ICD9 f ormat) or  3 (ICD10 f ormat)"RTN ","DGPTFTR ",39,0) D  LOG S DGCN T=1,DGD=DG SD-.01,DGT R=0,DGID=1 "RTN","DGP TFTR",40,0 ) ;DGTR=co unter for  # of messa ges genera ted, DGID= counter fo r DGIDN ar ray (DGIDN (DGID)=XMZ )"RTN","DG PTFTR",41, 0) ;DGCNT= counter fo r number o f lines in  MailMan m essage. Bu mped up in  DGPTRI* r outines"RT N","DGPTFT R",42,0) ; DGD=releas e date-.01 "RTN","DGP TFTR",43,0 ) ; DG*5.3 *614 - DGF IRST ident ifies firs t record i n a batch" RTN","DGPT FTR",44,0)  N DGFIRST  S DGFIRST =1"RTN","D GPTFTR",45 ,0) W !!," Now transm itting ",$ P(DGRTY0,U )," record s...""RTN" ,"DGPTFTR" ,46,0) W ! ,"Includes  records o f ""RTN"," DGPTFTR",4 7,0) ;"RTN ","DGPTFTR ",48,0)DAT  ;create a  MailMan m essage, tr ansmit it  and move o n to proce ss additio nal PTFs " RTN","DGPT FTR",49,0)  D:DGCNT>1  XMIT Q:$G (DGPTSLF)> 0  ;quit i f segment  lengths ar e wrong"RT N","DGPTFT R",50,0) S  DGD=$O(^D GP(45.83,D GD)) ;firs t time thr u, DGCNT i s 1, so XM IT is not  executed." RTN","DGPT FTR",51,0)  I DGD>0,D GD'>DGED D  SETTRAN^D GPTUTL1 Q: DGOUTX  ;c reate Mail Man messag e"RTN","DG PTFTR",52, 0) I DGD'> 0!(DGD>DGE D) D BULL^ DGPTFTR3 G  DATQ ;cre ate/send b ulletin"RT N","DGPTFT R",53,0) S  J=0 G PWR "RTN","DGP TFTR",54,0 )DATQ Q"RT N","DGPTFT R",55,0) ; "RTN","DGP TFTR",56,0 )PWR ;get  the PTF re cord and s tart proce ssing it"R TN","DGPTF TR",57,0)  Q:$G(DGPTS LF)>0  ;qu it if segm ent length s are wron g"RTN","DG PTFTR",58, 0) D CEN^D GPTUTL ;ch eck if cen sus can be  sent"RTN" ,"DGPTFTR" ,59,0) S P =J,J=$O(^D GP(45.83,D GD,"P",J))  G DAT:J'> 0,PWR:$P(^ (J,0),U,2) "RTN","DGP TFTR",60,0 ) I $D(^DG PT(J,0)),$ P(^(0),U,1 1)'=+DGRTY  G PWR"RTN ","DGPTFTR ",61,0) I  $P(DGCN0,U ,3)>DT,DGR TY=1 D CEN ^DGPTFTR3  G PWR:'Y"R TN","DGPTF TR",62,0)  S Y=$S($D( ^DGPT(J,70 )):+^(70), 1:0) D FMT ^DGPTUTL G  PWR:DGPTF MT<DGFMT"R TN","DGPTF TR",63,0)  ;LINES^DGP TFVC2 coun ts number  of lines f or transmi ssion"RTN" ,"DGPTFTR" ,64,0) S T 1=0,T2=999 9999,Y=J,X =0 S:DGRTY =2 T2=+DGC N0_".9",T1 =+$P(DGCN0 ,U,5) D LI NES^DGPTFV C2 I (DGCN T+X)>VAT(" F"),'$G(DG FIRST) S J =P G XMIT" RTN","DGPT FTR",65,0)  I $G(DGFI RST)=1 S D GFIRST=0"R TN","DGPTF TR",66,0)  K DICR S D GERR=0,DGS TCNT("P",J )=DGCNT"RT N","DGPTFT R",67,0) ; ^TMP("AEDI T",$J) & ^ TMP("AERRO R",$J) are  set in DG PTAE* rout ines. Used  to valida te data"RT N","DGPTFT R",68,0) W  !,$E($P(^ DPT(+^DGPT (J,0),0),U ),1,25),?2 7,"(#",J," )" S X=^DG PT(J,0) Q: '$D(^(0))   S DGNODE= ^(0),DGADM =$P(DGNODE ,U,2) D"RT N","DGPTFT R",69,0) .  W "  Admi tted: ",$T R($$FMTE^X LFDT(DGADM ,"5DF"),"  ","0")," "  K ^TMP("A EDIT",$J), ^TMP("AERR OR",$J) S  DGACNT=0"R TN","DGPTF TR",70,0)  . F DGZ=6, 4 W $$GET1 ^DIQ(45,J_ ",",DGZ)_"  ""RTN","D GPTFTR",71 ,0) . K DG NODE,DGZ Q "RTN","DGP TFTR",72,0 ) I DGRTY= 1 D COM"RT N","DGPTFT R",73,0) I  DGRTY=2 S  T2=+DGCN0 _".9",T1=+ $P(DGCN0,U ,5),(PTF,D GCI)=J D C OM1"RTN"," DGPTFTR",7 4,0) I DGE RR D OPEN^ DGPTFTR3 ; does clean up. delete s 45.83 da ta. kills  XMY, remov es segment s from Mai lMan messa ge. sends  Mailman me ssage to u ser that r ecord is r e-opened." RTN","DGPT FTR",75,0)  K ^TMP("A EDIT",$J)" RTN","DGPT FTR",76,0)  I 'DGERR  W ?70," Ok ay" S DGTR =DGTR+1 G  XMIT:DGCNT >VAT("F")" RTN","DGPT FTR",77,0)  G PWR"RTN ","DGPTFTR ",78,0) Q" RTN","DGPT FTR",79,0)  ;"RTN","D GPTFTR",80 ,0)XMIT ;t ransmit me ssage with  PTF segme nts"RTN"," DGPTFTR",8 1,0) K XMY  D ROUTER" RTN","DGPT FTR",82,0)  S XMZ=DGX MZ,^XMB(3. 9,XMZ,2,0) ="^3.92A^" _(DGCNT-1) _"^"_(DGCN T-1)_"^"_D T,DGJ=J"RT N","DGPTFT R",83,0) S  XMDUZ=.5, XMDUN=$P(^ VA(200,DUZ ,0),U)"RTN ","DGPTFTR ",84,0) S  DGPTSLF=0  D CHECK(XM Z) ;are se gment leng ths correc t?"RTN","D GPTFTR",85 ,0) I DGPT SLF>0 Q"RT N","DGPTFT R",86,0) D  ENT1^XMD  ;forward   message, d on't ask f or recipie nts"RTN"," DGPTFTR",8 7,0) W !," Transmissi on Queued"  S DGIDN(D GID)=XMZ"R TN","DGPTF TR",88,0)  F DGK=0:0  S DGK=$O(D GSTCNT("P" ,DGK)) Q:D GK'>0  D R EC"RTN","D GPTFTR",89 ,0) S DGFI RST=1"RTN" ,"DGPTFTR" ,90,0) K D GK S DGCNT =1,DGID=DG ID+1,J=DGJ  Q:J'>0  D  SETTRAN^D GPTUTL1 G: 'DGOUTX PW R"RTN","DG PTFTR",91, 0) Q"RTN", "DGPTFTR", 92,0) ;"RT N","DGPTFT R",93,0)RE C ;update  PTF RECORD  multiple  in PTF REL EASE (45.8 3). includ es PTF rec ord ien, d ate transm itted, & m essage ien "RTN","DGP TFTR",94,0 ) ;set PTF  STATUS="T ransmitted ""RTN","DG PTFTR",95, 0) S DGSEN FLG="""RTN ","DGPTFTR ",96,0) S  DIE="^DGP( 45.83,",DA =DGD,DR="1 0///"_DGK, DR(2,45.83 1)="1///TO DAY;2///"_ XMZ D ^DIE  K DA,DR,D IE"RTN","D GPTFTR",97 ,0) S DIE= "^DGPT(",D R="6///3", DA=DGK D ^ DIE K DA,D R,DIE"RTN" ,"DGPTFTR" ,98,0) K D GSENFLG"RT N","DGPTFT R",99,0) Q "RTN","DGP TFTR",100, 0) ;"RTN", "DGPTFTR", 101,0)COM  S T1=0,T2= 9999999 S: '$D(PTF) P TF=J S:PTF '=J PTF=J" RTN","DGPT FTR",102,0 )COM1 ;cal led from D GPTC1"RTN" ,"DGPTFTR" ,103,0) ;p ulls data  from PTF ( 45), PATIE NT(2) and  PTF CLOSE  OUT (45.84 ). Values  are used t o build se gments and  do data v alidation" RTN","DGPT FTR",104,0 ) F K=0,70 ,71,101,"4 01P" S @(" DG"_K)=$S( $D(^DGPT(J ,K)):^(K), 1:"")"RTN" ,"DGPTFTR" ,105,0) ;  pwc DG*5.3 *914 RSD S PEC# 2.6.5 .6 PTF TRA NSMISSION  via MailMa n "RTN","D GPTFTR",10 6,0) F K=1 0,.11,.3,. 32,.321,.3 217,.52,57  S @("DG"_ $S(K[".":$ E(K,2,99), 1:K))=$S($ D(^DGP(45. 84,J,K)):^ (K),$D(^DP T(+^DGPT(J ,0),$S(K'= 10:K,1:0)) ):$S(K'=10 :^(K),1:^( 0)),1:"")" RTN","DGPT FTR",107,0 ) F K=.02, .06 M @("D G"_$S(K[". ":$E(K,2,9 9),1:K))=^ DPT(+^DGPT (J,0),K)"R TN","DGPTF TR",108,0)  ;uses dif ferent pro cessing ro utines to  build segm ents and M ailMan bas ed on reco rd format. "RTN","DGP TFTR",109, 0) ;DGPTFM T=1 is ver y old reco rd format,  perhaps b efore ICD9  usage (no t sure)."R TN","DGPTF TR",110,0)  ;DGPTFMT= 2 is ICD9  record for mat"RTN"," DGPTFTR",1 11,0) ;DGP TFMT=3 is  ICD10 reco rd format" RTN","DGPT FTR",112,0 ) ;DGPTR*  & DGPTRI*  routines a nd similar , but reco rd format  is differe nt."RTN"," DGPTFTR",1 13,0) D ^D GPTFTR0:DG PTFMT=1,^D GPTR0:DGPT FMT=2,^DGP TRI0:DGPTF MT=3"RTN", "DGPTFTR", 114,0) ;"R TN","DGPTF TR",115,0) Q ;"RTN"," DGPTFTR",1 16,0) L -^ DGP(45.83) "RTN","DGP TFTR",117, 0) F K=0,1 0,701,"401 P",101,11, 3,32,41,52 ,57,70,321 ,3217,502, 702,"02"," 06" K @("D G"_K)"RTN" ,"DGPTFTR" ,118,0) K  DGPICD10,D GCDR,DGT,D IC,DGADM,D GAO,DGDOB, DGHEAD,DGJ ,DGK,DGL,D GM,DGNAM,D GNT,DGO,DG SSN,DGSUD, DGSUR,DGTD ,DGX,DGXLS ,E,ERR,F,G ,H,I,K,L,T ,W,Z,DGPRO C,DGPROCD  ;** NOTE:  do not kil l variable s needed b y PTF load /edit opti on!!!"RTN" ,"DGPTFTR" ,119,0) ;D GPTFVC1 &  DGPTFVC2 d o expanded  ptf close  out edits "RTN","DGP TFTR",120, 0) ;DGPTFV C3 does va lidation c hecks for  ptf additi onal quest ions"RTN", "DGPTFTR", 121,0) I $ D(DGERR),D GERR<1 D ^ DGPTFVC1 D :'T1 ^DGPT FVC3"RTN", "DGPTFTR", 122,0) I $ D(DGERR),D GERR<1 D E N^DGPTFVC2 "RTN","DGP TFTR",123, 0) Q"RTN", "DGPTFTR", 124,0) ;"R TN","DGPTF TR",125,0) LOG ;calle d from PRI NT+1^DGPTF 2,CLS+1^DG PTF2,EN^DG PTFVC"RTN" ,"DGPTFTR" ,126,0) D  LOG^DGPTFT R1:DGPTFMT =1,LOG^DGP TR1:DGPTFM T=2,LOG^DG PTRI1:DGPT FMT=3,COM: $D(DGERR)  ;note: COM  is not ca lled unles s DGERR ex ists"RTN", "DGPTFTR", 127,0) Q"R TN","DGPTF TR",128,0)  ;"RTN","D GPTFTR",12 9,0) ;-- c heck for r eal queue  if census  should be  removed fo r national  release"R TN","DGPTF TR",130,0) ROUTER ;ca lled from  DGPTF099,D GPTRPO"RTN ","DGPTFTR ",131,0) ; DGSDI is l ocal or re mote addre ss"RTN","D GPTFTR",13 2,0) ;I $D (XMDF) the n all addr essing res trictions  are waived "RTN","DGP TFTR",133, 0) ;XMN -  Can't find  this vari able in Ma ilMan docu mentation.  May not d o anything ."RTN","DG PTFTR",134 ,0) S XMDU Z=.5 F DGS DI=0:0 S D GSDI=$O(VA T(DGSDI))  Q:'DGSDI   S X=VAT(DG SDI),XMN=0 ,XMDF="" D  INST^XMA2 1 K XMN,XM DF"RTN","D GPTFTR",13 5,0) S XMY (DUZ)="""R TN","DGPTF TR",136,0)  Q"RTN","D GPTFTR",13 7,0) ;"RTN ","DGPTFTR ",138,0)CH ECK(DGPTXM Z) ;check  if every t wo lines i n message  body equal  384 chara cters"RTN" ,"DGPTFTR" ,139,0) N  DGPTLAST,D GPTLOOP,DG PTNODE,DGP TTEXT,DGPT TOT"RTN"," DGPTFTR",1 40,0) S DG PTNODE=$G( ^XMB(3.9,D GPTXMZ,2,0 ))"RTN","D GPTFTR",14 1,0) S DGP TLAST=$P(D GPTNODE,U, 4)"RTN","D GPTFTR",14 2,0) F DGP TLOOP=1:2: DGPTLAST D   Q:$G(DGP TSLF)=1"RT N","DGPTFT R",143,0)  .S DGPTTOT =$L($G(^XM B(3.9,DGPT XMZ,2,DGPT LOOP,0)))+ $L($G(^XMB (3.9,DGPTX MZ,2,DGPTL OOP+1,0))) "RTN","DGP TFTR",144, 0) .I DGPT TOT'=384 D "RTN","DGP TFTR",145, 0) ..S DGP TSLF=1 ;se gment leng th flag"RT N","DGPTFT R",146,0)  ..D QMSG(D GPTXMZ)"RT N","DGPTFT R",147,0)  ..W !!,"Th ere is a p roblem wit h the segm ent length  of a PTF  record.""R TN","DGPTF TR",148,0)  ..W !,"Th e MailMan  message nu mber is "_ DGPTXMZ_". ""RTN","DG PTFTR",149 ,0) ..W !, "Please lo g a Remedy  ticket. S topping tr ansmission .",!"RTN", "DGPTFTR", 150,0) Q"R TN","DGPTF TR",151,0)  ;"RTN","D GPTFTR",15 2,0)QMSG(D GPTMIEN) ; notify oth ers about  bad segmen t length"R TN","DGPTF TR",153,0)  N ZTDESC, ZTDTH,ZTIO ,ZTRTN,ZTS AVE"RTN"," DGPTFTR",1 54,0) S ZT DESC="DG P TF TRANSMI SSION DNS   S",ZTDTH= $$NOW^XLFD T(),ZTIO=" ",ZTRTN="S MSG^DGPTFT R""RTN","D GPTFTR",15 5,0) S ZTS AVE("DGPTM IEN")="""R TN","DGPTF TR",156,0)  D ^%ZTLOA D"RTN","DG PTFTR",157 ,0) Q"RTN" ,"DGPTFTR" ,158,0) ;" RTN","DGPT FTR",159,0 )SMSG ;sen d MailMan  message"RT N","DGPTFT R",160,0)  N DGPTTEXT ,XMDUZ,XMS UB,XMTEXT, XMY"RTN"," DGPTFTR",1 61,0) S XM SUB="Stati on "_$P($$ SITE^VASIT E(),U,3)_"  has wrong  PTF segme nt length" "RTN","DGP TFTR",162, 0) S XMDUZ =$S($G(DUZ )>0:$G(DUZ ),1:.5)"RT N","DGPTFT R",163,0)  S DGPTTEXT (1)="The P TF records  contained  in this m essage can not be tra nsmitted"" RTN","DGPT FTR",164,0 ) S DGPTTE XT(2)="to  AITC due t o format o f the cont ent issue. ""RTN","DG PTFTR",165 ,0) S DGPT TEXT(3)="  ""RTN","DG PTFTR",166 ,0) S DGPT TEXT(4)="C ontact the  support h elp desk a nd report. ""RTN","DG PTFTR",167 ,0) S DGPT TEXT(5)="  ""RTN","DG PTFTR",168 ,0) S DGPT TEXT(6)="R etransmiss ion will n eed to be  attempted  once the t ransmissio n""RTN","D GPTFTR",16 9,0) S DGP TTEXT(7)=" message fo rmat has b een correc ted.""RTN" ,"DGPTFTR" ,170,0) S  DGPTTEXT(8 )=" ""RTN" ,"DGPTFTR" ,171,0) S  DGPTTEXT(9 )="The loc al MailMan  message n umber is:  "_DGPTMIEN "RTN","DGP TFTR",172, 0) S XMTEX T="DGPTTEX T(""RTN"," DGPTFTR",1 73,0) S XM Y(DUZ)=""" RTN","DGPT FTR",174,0 ) S XMY("P II                                ")="""RTN ","DGPTFTR ",175,0) D  ^XMD"RTN" ,"DGPTFTR" ,176,0) Q" RTN","DGPT FVC1")0^21 ^B43425692 "RTN","DGP TFVC1",1,0 )DGPTFVC1  ;ALB/AS/AD L,HIOFO/FT  - Expande d PTF Clos e-Out Edit s ;10/21/1 4 2:33pm"R TN","DGPTF VC1",2,0)  ;;5.3;Regi stration;* *52,58,79, 114,164,40 0,342,466, 415,493,51 2,510,544, 629,817,85 0,884,914* *;Aug 13,  1993;Build  104"RTN", "DGPTFVC1" ,3,0) ;;AD L;Updated  for CSV Pr oject;;Mar  26, 2003" RTN","DGPT FVC1",4,0)  ;"RTN","D GPTFVC1",5 ,0) ; XLFD T APIs - # 10103"RTN" ,"DGPTFVC1 ",6,0) ; I CDEX APIs  - #5747"RT N","DGPTFV C1",7,0) ;  ICDXCODE  APIs - #56 99"RTN","D GPTFVC1",8 ,0) ; VADP T APIs - # 10061"RTN" ,"DGPTFVC1 ",9,0) ;"R TN","DGPTF VC1",10,0)  ;Called f rom Q+2^DG PTFTR. Var iable must  be passed  in: PTF"R TN","DGPTF VC1",11,0)  ;Variable  returned:  DGERR.    DGERR <--  1 if recor d fails to  pass a ch eck; DGERR  <-- "" if  record pa sses all c hecks"RTN" ,"DGPTFVC1 ",12,0) ;" RTN","DGPT FVC1",13,0 ) Q:'$D(PT F)"RTN","D GPTFVC1",1 4,0) S DGE RR="",DGV( 701)=$S($D (^DGPT(PTF ,70)):^(70 ),1:""),DG V(101)=^(0 ),DGSUFFIX =$P(DGV(10 1),"^",5), DGV("FEE") =$P(DGV(10 1),"^",4), DFN=$P(DGV (101),"^", 1)"RTN","D GPTFVC1",1 5,0) ;"RTN ","DGPTFVC 1",16,0) I  $P(DGV(10 1),"^",2)> 2820700 D  AO"RTN","D GPTFVC1",1 7,0) ;"RTN ","DGPTFVC 1",18,0) I  DGRTY=1,D GV("FEE")  D MT"RTN", "DGPTFVC1" ,19,0) ;"R TN","DGPTF VC1",20,0)  ; DG*512,  sck/Remov e 101-Mean s Test ind icator = ' U' xmit bl ock"RTN"," DGPTFVC1", 21,0) ;"RT N","DGPTFV C1",22,0)  ; 850 - aa s - hard c oded ICD c odes, diag nosis valu es, differ ent for IC D-9 and IC D-10"RTN", "DGPTFVC1" ,23,0) N S YS,EFFDATE ,IMPDATE,D GPTDAT"RTN ","DGPTFVC 1",24,0) D  EFFDATE^D GPTIC10($G (PTF))"RTN ","DGPTFVC 1",25,0) S  SYS=$$SYS ^ICDEX("DI AG",EFFDAT E)"RTN","D GPTFVC1",2 6,0) I $D( ^DPT(DFN,5 7)),$P(^(5 7),"^",4)> 0,SYS=1 S  S0=$P(^(57 ),"^",4),D GDX=$S(S0= 1!(S0=3):" 344.1",1:" 344.0"),DG SCI="" F D GX=0:0 S D GX=$O(^DGP T(PTF,"M", DGX)) Q:DG X'>0  S DG NODE(0)=^( DGX,0),DGN ODE=$$STR5 01^DGPTFUT (PTF,DGX), DGSCI="" D  SCI"RTN", "DGPTFVC1" ,27,0) I $ D(^DPT(DFN ,57)),$P(^ (57),"^",4 )>0,SYS=30  S S0=$P(^ (57),"^",4 ),DGDX=$S( S0=1!(S0=3 ):"G82.2", 1:"G82.5") ,DGSCI=""  F DGX=0:0  S DGX=$O(^ DGPT(PTF," M",DGX)) Q :DGX'>0  S  DGNODE(0) =^(DGX,0), DGNODE=$$S TR501^DGPT FUT(PTF,DG X),DGSCI=" " D SCI"RT N","DGPTFV C1",28,0)  ;"RTN","DG PTFVC1",29 ,0) S DGDP ="",DGDISP O=$P(DGV(7 01),"^",6) ,DGRECSUF= $P(DGV(701 ),"^",13)" RTN","DGPT FVC1",30,0 ) I DGRTY= 1 D"RTN"," DGPTFVC1", 31,0) .S D GSTATYP=$S (DGDISPO=1 2!(DGDISPO =13):30,DG DISPO=10:4 2,DGDISPO= 8:40,1:"") "RTN","DGP TFVC1",32, 0) .I DGST ATYP]"" D" RTN","DGPT FVC1",33,0 ) ..D NUMA CT^DGPTSUF (DGSTATYP) "RTN","DGP TFVC1",34, 0) ..I DGA NUM>0 F I= 1:1:DGANUM  I DGSUFFI X=DGSUFNAM (I) D"RTN" ,"DGPTFVC1 ",35,0) .. .I DGDISPO '=8 I DGRE CSUF=DGSUF NAM(DGANUM ) S DGDP=5  D DP"RTN" ,"DGPTFVC1 ",36,0) .. .I DGDISPO =8 N DGANU M,DGSUFNAM  D NUMACT^ DGPTSUF(42 ) I DGRECS UF=DGSUFNA M(DGANUM)  S DGDP=5 D  DP"RTN"," DGPTFVC1", 37,0) .K D GANUM,DGST ATYP,DGSUF NAM,I"RTN" ,"DGPTFVC1 ",38,0) ;" RTN","DGPT FVC1",39,0 ) I DGRTY= 1 S %=$P(D GV(701),"^ ",3) I %=4 !(%=6)!(%= 7) S DGDP= "" D OP I  $P(DGV(701 ),"^",5)=1  S DGERR=1  W !,"701  VA AUSPICE S",?23," v alue incon sistent fo r discharg e""RTN","D GPTFVC1",4 0,0) ;"RTN ","DGPTFVC 1",41,0) ; If PRRTP t reating sp ecialty, m ust have v alid PRRTP  suffix"RT N","DGPTFV C1",42,0)  ;Fee recor ds would n ot contain  PRRTP spe cialties"R TN","DGPTF VC1",43,0)  I 'DGV("F EE"),"^25^ 26^27^28^2 9^38^39^"[ (U_$P(DGV( 701),U,2)_ U) D"RTN", "DGPTFVC1" ,44,0) .I  DGSUFFIX'= "PA",(DGSU FFIX'="PB" ),(DGSUFFI X'="PC"),( DGSUFFIX'= "PD") D"RT N","DGPTFV C1",45,0)  ..S DGERR= 1"RTN","DG PTFVC1",46 ,0) ..W !, "101 SUFFI X",?23,"va lue must b e set to a  valid PRR TP suffix. ""RTN","DG PTFVC1",47 ,0) ;"RTN" ,"DGPTFVC1 ",48,0) D  RACETHNC"R TN","DGPTF VC1",49,0)  K DGDISPO ,DGRECSUF, DGV,DGDP,D GDX,DGSCI, DGSUFFIX,D GNODE,DGX, %,S0,I,X"R TN","DGPTF VC1",50,0)  I DGERR H  4"RTN","D GPTFVC1",5 1,0) Q"RTN ","DGPTFVC 1",52,0) ; "RTN","DGP TFVC1",53, 0)SCI ;"RT N","DGPTFV C1",54,0)  N EFFDATE, IMPDATE"RT N","DGPTFV C1",55,0)  D EFFDATE^ DGPTIC10(P TF)"RTN"," DGPTFVC1", 56,0) F X= 1:1:25 I $ P(DGNODE," ^",X) S DG PTTMP=$$IC DDATA^ICDX CODE("DIAG ",+$P(DGNO DE,"^",X), EFFDATE) D "RTN","DGP TFVC1",57, 0) . I +DG PTTMP>0&($ P(DGPTTMP, U,10)) S:$ E($P(DGPTT MP,"^",2), 1,5)=DGDX  DGSCI=10 Q :DGSCI"RTN ","DGPTFVC 1",58,0) I  'DGSCI S  DGERR=1,%= $P(DGNODE( 0),"^",10) ,X=$TR($$F MTE^XLFDT( %,"5DF"),"  ","0") W  !,"501 ",X ," SCI of  ",S0,?23,"  requires  an ICD Dia gnosis cod e beginnin g with",!? 12," or eq ual to ",D GDX"RTN"," DGPTFVC1", 59,0) Q"RT N","DGPTFV C1",60,0)  ;"RTN","DG PTFVC1",61 ,0)MT S DG VMT=$P(DGV (101),"^", 10),DGX=99 9 G DGX:DG VMT']"" I  +$P(DGV(10 1),"^",2)< 2860700!(D GSUFFIX="B U") S DGX= "X" G DGX" RTN","DGPT FVC1",62,0 ) S DGZEC= $P($G(^DGP T(PTF,101) ),U,8),DGZ EC=$S($D(^ DIC(8,+DGZ EC,0)):^(0 ),1:"") I  $P(DGZEC,U ,5)="N" S  DGX="N" G  DGX"RTN"," DGPTFVC1", 63,0) S DG T=$P(DGV(7 01),".") G  AS:'$O(^D GMT(408.31 ,"AD",1,DF N,0)) S DG Z1=$$LST^D GMTU(DFN,D GT) K:DGZ1 ']"" DGZ1" RTN","DGPT FVC1",64,0 ) I DGVMT= "X" K DGX, DGVMT Q"RT N","DGPTFV C1",65,0)  S DGX=$S(' $D(DGZ1):" U",1:$P(DG Z1,U,4))"R TN","DGPTF VC1",66,0)  ; Determi ne if the  Pending Ad judication  is for MT (C) or GMT (G)"RTN"," DGPTFVC1", 67,0) I DG X="P" D  G  DGX"RTN", "DGPTFVC1" ,68,0) . I  '+$P($G(D GZ1),U) S  DGX="U" Q" RTN","DGPT FVC1",69,0 ) . S DGX= $$PA^DGMTU TL($P(DGZ1 ,U)),DGX=$ S('$D(DGX) :"U",DGX=" MT":"C",DG X="GMT":"G ",1:"U")"R TN","DGPTF VC1",70,0)  I DGX="A" ,$P(DGZEC, U,4)=3,$$S C^DGMTR(DF N),$$ANYSC ^DGPTSCAN( PTF) S DGX ="AS" G DG X"RTN","DG PTFVC1",71 ,0) I DGX= "A","^1^3^ "[("^"_$P( DGZEC,U,4) _"^"),$P($ G(^DPT(DFN ,.3)),U,2) >0 S DGX=" AS" G DGX" RTN","DGPT FVC1",72,0 ) S DGX=$S (DGX="A":" AN","BCGN" [DGX:DGX,1 :"U") G AS :DGX="U" G  DGX:DGX'= "N""RTN"," DGPTFVC1", 73,0)AS S  DGZ=$S($D( ^DPT(DFN,. 321)):^(.3 21),1:0) I  $P(DGZ,U, 2)="Y"!($P (DGZ,U,3)= "Y") S DGX ="AS" G DG X"RTN","DG PTFVC1",74 ,0) ; pwc  DG*5.3*914  RSD SPEC#  2.6.5.6 P TF TRANSMI SSION via  MailMan"RT N","DGPTFV C1",75,0)  S DGZ=$S($ D(^DPT(DFN ,.3217)):^ (.3217),1: 0) I $P(DG Z,U,1)="Y"  S DGX="AS " G DGX"RT N","DGPTFV C1",76,0)  S DGZ=$S($ D(^DPT(DFN ,.322)):^( .322),1:0)  I $P(DGZ, U,13)="Y"  S DGX="AS"  G DGX"RTN ","DGPTFVC 1",77,0) N  DGNTARR S  DGZ=$S($$ GETCUR^DGN TAPI(DFN," DGNTARR")> 0:DGNTARR( "NTR"),1:" ") I $P(DG Z,U)="Y" S  DGX="AS"  G DGX"RTN" ,"DGPTFVC1 ",78,0) S  DGZ=$$GETS TAT^DGMSTA PI(DFN) I  $P(DGZ,U,2 )="Y" S DG X="AS" G D GX"RTN","D GPTFVC1",7 9,0) I $P( DGZEC,U,5) ="Y",$P(DG ZEC,U,4)<4 ,"^2^15^"' [(U_$P(DGZ EC,U,9)_U)  S DGX="AS " G DGX"RT N","DGPTFV C1",80,0)  S DGX="AN" "RTN","DGP TFVC1",81, 0)DGX ;DG* 5.3*817/Re move 101-M eans Test  indicator  = 'U' xmit  block for  FEE BASIS  PTF "RTN" ,"DGPTFVC1 ",82,0) I  DGVMT'=DGX ,DGVMT'="U " S DGERR= 1 W !,"101  ","MEANS  TEST",?23, " value ", DGVMT,$S(D GVMT']"":" blank",DGV MT="X":" o nly for ad missions p rior to 7/ 1/86 or do micilliary  use",1:"  inconsiste nt with el igibility  data")"RTN ","DGPTFVC 1",83,0) K  DGZEC,DGZ ,DGZ1,DGT, DGX,DGVMT  Q"RTN","DG PTFVC1",84 ,0) ;"RTN" ,"DGPTFVC1 ",85,0)DP  I $P(DGV(7 01),"^",3) '=5 S DGER R=1 W !,"7 01 ",$E("T YPE OF DIS POSITION", 1,18),?23, " value in consistent  for disch arge""RTN" ,"DGPTFVC1 ",86,0)OP  I $P(DGV(7 01),"^",4) =1 S DGERR =1 W !,"70 1 ",$E("OU TPATIENT T REATMENT", 1,18),?23, " value in consistent  for disch arge" Q:DG DP="""RTN" ,"DGPTFVC1 ",87,0) I  $P(DGV(701 ),"^",5)=2  S DGERR=1  W !,"701  VA AUSPICE S",?23," v alue incon sistent fo r discharg e""RTN","D GPTFVC1",8 8,0) Q"RTN ","DGPTFVC 1",89,0) ; "RTN","DGP TFVC1",90, 0)AO I DGP TFMT<2 D   Q"RTN","DG PTFVC1",91 ,0) .S %=$ S($D(^DGPT (PTF,101)) :$P(^(101) ,"^",4),1: "")"RTN"," DGPTFVC1", 92,0) .S % =$S($D(^DI C(45.82,+% ,0)):$P(^( 0),"^",1), 1:"")"RTN" ,"DGPTFVC1 ",93,0) .S  I=$S($D(^ DPT(DFN,.3 21)):^(.32 1),1:"")"R TN","DGPTF VC1",94,0)  .S:$P(I," ^",2)="Y"& (%'=6) DGE RR=1,DGV(" E")=1"RTN" ,"DGPTFVC1 ",95,0) .W :$D(DGV("E ")) !,"101  AGENT ORA NGE",?23,"  value ",$ S(DGV("E") :"can only  be used w ith COB of  '6'",1:"i s inconsis tent with  Vietnam Se rvice and/ or COB")"R TN","DGPTF VC1",96,0)  ;"RTN","D GPTFVC1",9 7,0) N AO, AOL,TMP"RT N","DGPTFV C1",98,0)  S TMP=$G(^ DPT(DFN,.3 21))"RTN", "DGPTFVC1" ,99,0) S A O=$S($P(TM P,"^",2)=" Y":1,1:0)" RTN","DGPT FVC1",100, 0) S AOL=$ P(TMP,"^", 13)"RTN"," DGPTFVC1", 101,0) Q:( 'AO)"RTN", "DGPTFVC1" ,102,0) Q: (AOL'="")" RTN","DGPT FVC1",103, 0) S DGERR =1,DGV("E" )=1"RTN"," DGPTFVC1", 104,0) W ! ,"101 AGEN T ORANGE L OCATION",? 23,"value  required i f exposure  to Agent  Orange cla imed""RTN" ,"DGPTFVC1 ",105,0) Q "RTN","DGP TFVC1",106 ,0)RACETHN C        ; Race and e thnicity c heck"RTN", "DGPTFVC1" ,107,0) ;E nsure that  a value f or ethnici ty and at  least one  race is on  file."RTN ","DGPTFVC 1",108,0)  ;Ensure al l active r ace/ethnic ity values  have a va lid PTF va lue and an "RTN","DGP TFVC1",109 ,0) ;assoc iated coll ection met hod.  Ensu re all col lection me thods have  a"RTN","D GPTFVC1",1 10,0) ;val id PTF val ue.  Ignor e race/eth nicity ent ries that  are inacti ve or"RTN" ,"DGPTFVC1 ",111,0) ; invalid po inters.  N ote: PTF s ends first  active et hnicity an d first"RT N","DGPTFV C1",112,0)  ;six acti ve races." RTN","DGPT FVC1",113, 0) N REF,I EN,TYPE,TE XT,PTRVAL, PTRMTHD,NU M,MAX"RTN" ,"DGPTFVC1 ",114,0) N  VALIDVAL, VALIDMTH,V ALUE,VADM" RTN","DGPT FVC1",115, 0) D DEM^V ADPT"RTN", "DGPTFVC1" ,116,0) F  REF=11,12  D"RTN","DG PTFVC1",11 7,0) .I RE F=12 D"RTN ","DGPTFVC 1",118,0)  ..S MAX=6" RTN","DGPT FVC1",119, 0) ..S TYP E=1"RTN"," DGPTFVC1", 120,0) ..S  VALIDVAL= ",3,8,9,A, B,C,D,""RT N","DGPTFV C1",121,0)  ..S VALID MTH=",S,P, O,U,""RTN" ,"DGPTFVC1 ",122,0) . .S TEXT="R ACE""RTN", "DGPTFVC1" ,123,0) .I  REF=11 D" RTN","DGPT FVC1",124, 0) ..S MAX =1"RTN","D GPTFVC1",1 25,0) ..S  TYPE=2"RTN ","DGPTFVC 1",126,0)  ..S TEXT=" ETHNICITY" "RTN","DGP TFVC1",127 ,0) ..S VA LIDVAL=",H ,N,D,U,""R TN","DGPTF VC1",128,0 ) ..S VALI DMTH=",S,P ,O,U,""RTN ","DGPTFVC 1",129,0)  .S NUM=1"R TN","DGPTF VC1",130,0 ) .S IEN=0 "RTN","DGP TFVC1",131 ,0) .F  S  IEN=+$O(VA DM(REF,IEN )) Q:'IEN   D  Q:NUM> MAX"RTN"," DGPTFVC1", 132,0) ..S  PTRVAL=+V ADM(REF,IE N)"RTN","D GPTFVC1",1 33,0) ..S  PTRMTHD=+$ G(VADM(REF ,IEN,1))"R TN","DGPTF VC1",134,0 ) ..Q:'PTR VAL"RTN"," DGPTFVC1", 135,0) ..Q :$$INACTIV E^DGUTL4(P TRVAL,TYPE )"RTN","DG PTFVC1",13 6,0) ..S N UM=NUM+1"R TN","DGPTF VC1",137,0 ) ..S VALU E=$$PTR2CO DE^DGUTL4( PTRVAL,TYP E,4)"RTN", "DGPTFVC1" ,138,0) .. I (VALUE=" ")!(VALIDV AL'[VALUE)  D  Q"RTN" ,"DGPTFVC1 ",139,0) . ..W !,"701  ",TEXT,?2 3,"missing /invalid x mit value" "RTN","DGP TFVC1",140 ,0) ...S D GERR=1"RTN ","DGPTFVC 1",141,0)  ..I ('PTRM THD) D  Q" RTN","DGPT FVC1",142, 0) ...W !, "701 ",TEX T,?23,"met hod of col lection mi ssing/inva lid""RTN", "DGPTFVC1" ,143,0) .. .S DGERR=1 "RTN","DGP TFVC1",144 ,0) ..S VA LUE=$$PTR2 CODE^DGUTL 4(PTRMTHD, 3,4)"RTN", "DGPTFVC1" ,145,0) .. I (VALUE=" ")!(VALIDM TH'[VALUE)  D  Q"RTN" ,"DGPTFVC1 ",146,0) . ..W !,"701  ",TEXT,?2 3,"missing /invalid x mit value  for method  of collec tion""RTN" ,"DGPTFVC1 ",147,0) . ..S DGERR= 1"RTN","DG PTFVC1",14 8,0) Q"RTN ","DGPTLMU 6")0^55^B9 185980"RTN ","DGPTLMU 6",1,0)DGP TLMU6 ;ALB /MTC - PTF  A/P LIST  MANAGER UT ILITY CONT . ;9-24-92 "RTN","DGP TLMU6",2,0 ) ;;5.3;Re gistration ;**606,914 **;Aug 13,  1993;Buil d 104"RTN" ,"DGPTLMU6 ",3,0) ;"R TN","DGPTL MU6",4,0)D I501 ;-- t his functi on will lo ad the 501  informati on into th e display  array"RTN" ,"DGPTLMU6 ",5,0) N X ,Y,I,J"RTN ","DGPTLMU 6",6,0) S  I=0 F  S I =$O(^DGPT( DGPTF,"M", I)) Q:'I   D"RTN","DG PTLMU6",7, 0) . S X1= "",X=$G(^D GPT(DGPTF, "M",I,0))  Q:X']"""RT N","DGPTLM U6",8,0) .  S ^TMP("A RCPTFDI",$ J,$$NUM^DG PTLMU4(.NU MREC),0)=" ""RTN","DG PTLMU6",9, 0) . S Y=" Movement D t :"_$S($P (X,U,10):$ $FTIME^VAL M1($P(X,U, 10)),1:"") "RTN","DGP TLMU6",10, 0) . S X1= $$SETSTR^V ALM1(Y,X1, 1,40)"RTN" ,"DGPTLMU6 ",11,0) .  S ^TMP("AR CPTFDI",$J ,$$NUM^DGP TLMU4(.NUM REC),0)=X1 ,X1="""RTN ","DGPTLMU 6",12,0) .  S Y="Trea ted for SC  condit :" _$S($P(X,U ,18)=1:"YE S",1:"NO") "RTN","DGP TLMU6",13, 0) . S X1= $$SETSTR^V ALM1(Y,X1, 1,40)"RTN" ,"DGPTLMU6 ",14,0) .  S Y="Treat ed for AO  condit :"_ $S($P(X,U, 26)=1:"YES ",1:"NO")" RTN","DGPT LMU6",15,0 ) . S X1=$ $SETSTR^VA LM1(Y,X1,4 5,30)"RTN" ,"DGPTLMU6 ",16,0) .  S ^TMP("AR CPTFDI",$J ,$$NUM^DGP TLMU4(.NUM REC),0)=X1 ,X1="""RTN ","DGPTLMU 6",17,0) .  S Y="Trea ted for IR  condit :" _$S($P(X,U ,27)=1:"YE S",1:"NO") "RTN","DGP TLMU6",18, 0) . S X1= $$SETSTR^V ALM1(Y,X1, 1,40)"RTN" ,"DGPTLMU6 ",19,0) .  S Y="Treat ed for EC  condit :"_ $S($P(X,U, 28)=1:"YES ",1:"NO")" RTN","DGPT LMU6",20,0 ) . ;PWC D G*5.3*914  RSD SPEC#  2.6.5.2.4  <501> Scre en Camp Le jeune  "RT N","DGPTLM U6",21,0)  . S X1=$$S ETSTR^VALM 1(Y,X1,45, 30)"RTN"," DGPTLMU6", 22,0) . S  Y="Treated  for CL co ndit :"_$S ($P(X,U,33 )=1:"YES", 1:"NO")"RT N","DGPTLM U6",23,0)  . S X1=$$S ETSTR^VALM 1(Y,X1,45, 30)"RTN"," DGPTLMU6", 24,0) . S  ^TMP("ARCP TFDI",$J,$ $NUM^DGPTL MU4(.NUMRE C),0)=X1,X 1="""RTN", "DGPTLMU6" ,25,0) . S  Y="Leave  Days :"_$S ($P(X,U,3) :$P(X,U,3) ,1:"")"RTN ","DGPTLMU 6",26,0) .  S X1=$$SE TSTR^VALM1 (Y,X1,1,40 )"RTN","DG PTLMU6",27 ,0) . S Y= "Pass Days  :"_$S($P( X,U,4):$P( X,U,4),1:" ")"RTN","D GPTLMU6",2 8,0) . S X 1=$$SETSTR ^VALM1(Y,X 1,45,30)"R TN","DGPTL MU6",29,0)  . S ^TMP( "ARCPTFDI" ,$J,$$NUM^ DGPTLMU4(. NUMREC),0) =X1,X1=""" RTN","DGPT LMU6",30,0 ) . S Y="L osing Spec ialty :"_$ S($P(X,U,2 ):$P(^DIC( 42.4,$P(X, U,2),0),U) ,1:"")"RTN ","DGPTLMU 6",31,0) .  S X1=$$SE TSTR^VALM1 (Y,X1,1,75 )"RTN","DG PTLMU6",32 ,0) . S ^T MP("ARCPTF DI",$J,$$N UM^DGPTLMU 4(.NUMREC) ,0)=X1,X1= """RTN","D GPTLMU6",3 3,0) .;"RT N","DGPTLM U6",34,0)  .;-- check  for ICD c odes"RTN", "DGPTLMU6" ,35,0) . S  ^TMP("ARC PTFDI",$J, $$NUM^DGPT LMU4(.NUMR EC),0)="IC D CODES :" "RTN","DGP TLMU6",36, 0) . F J=5 :1:9,11:1: 15 I $P(X, U,J) D"RTN ","DGPTLMU 6",37,0) . . S Y=$$IC DDX^ICDCOD E($P(X,U,J ),$P(X,U,1 0)),Y=$P(Y ,U,2)_" -  "_$P(Y,U,4 )"RTN","DG PTLMU6",38 ,0) .. S ^ TMP("ARCPT FDI",$J,$$ NUM^DGPTLM U4(.NUMREC ),0)=" "_Y "RTN","DGP TLMU6",39, 0) .;"RTN" ,"DGPTLMU6 ",40,0) .; -- check f or 300 nod e informat ion"RTN"," DGPTLMU6", 41,0) .;"R TN","DGPTL MU6",42,0)  . S X2=$G (^DGPT(DGP TF,"M",I,3 00)) I X2] "" D DI300 ^DGPTLMU4( X2)"RTN"," DGPTLMU6", 43,0) Q"RT N","DGPTLM U6",44,0)  ;"RTN","DG PTLMU6",45 ,0)DI535 ; -- this fu nction wil l load the  535 infor mation"RTN ","DGPTLMU 6",46,0) N  Y,X,X1,DG 535"RTN"," DGPTLMU6", 47,0) S DG 535=0 F  S  DG535=$O( ^DGPT(DGPT F,535,DG53 5)) Q:'DG5 35  D"RTN" ,"DGPTLMU6 ",48,0) .  S ^TMP("AR CPTFDI",$J ,$$NUM^DGP TLMU4(.NUM REC),0)="" "RTN","DGP TLMU6",49, 0) . S X=$ G(^DGPT(DG PTF,535,DG 535,0)),X1 ="""RTN"," DGPTLMU6", 50,0) . S  Y="Ward Mo vement Dat e :"_$S($P (X,U,10):$ $FTIME^VAL M1($P(X,U, 10)),1:"") "RTN","DGP TLMU6",51, 0) . S X1= $$SETSTR^V ALM1(Y,X1, 1,40)"RTN" ,"DGPTLMU6 ",52,0) .  S Y="Losin g Ward Spe cialty :"_ $P(^DIC(42 .4,$P(X,U, 2),0),U,1) "RTN","DGP TLMU6",53, 0) . S X1= $$SETSTR^V ALM1(Y,X1, 45,30)"RTN ","DGPTLMU 6",54,0) .  S ^TMP("A RCPTFDI",$ J,$$NUM^DG PTLMU4(.NU MREC),0)=X 1,X1="""RT N","DGPTLM U6",55,0)  . S Y="Lea ve Days :  "_$P(X,U,3 )"RTN","DG PTLMU6",56 ,0) . S X1 =$$SETSTR^ VALM1(Y,X1 ,1,40)"RTN ","DGPTLMU 6",57,0) .  S Y="Pass  Days :"_$ P(X,U,4)"R TN","DGPTL MU6",58,0)  . S X1=$$ SETSTR^VAL M1(Y,X1,45 ,30)"RTN", "DGPTLMU6" ,59,0) . S  ^TMP("ARC PTFDI",$J, $$NUM^DGPT LMU4(.NUMR EC),0)=X1, X1="""RTN" ,"DGPTLMU6 ",60,0) .  S Y="Losin g Ward : " _$P(^DIC(4 2,$P(X,U,6 ),0),U)"RT N","DGPTLM U6",61,0)  . S X1=$$S ETSTR^VALM 1(Y,X1,1,4 0)"RTN","D GPTLMU6",6 2,0) . S ^ TMP("ARCPT FDI",$J,$$ NUM^DGPTLM U4(.NUMREC ),0)=X1,X1 ="""RTN"," DGPTLMU6", 63,0) Q"RT N","DGPTLM U6",64,0)  ;"RTN","DG PTR0")0^22 ^B27460595 "RTN","DGP TR0",1,0)D GPTR0 ;MJK /JS/ADL/TJ ,HIOFO/FT  - PTF TRAN SMISSION ; 4/21/15 11 :28am"RTN" ,"DGPTR0", 2,0) ;;5.3 ;Registrat ion;**114, 247,338,34 2,510,524, 565,678,72 9,664,850, 884,914**; Aug 13, 19 93;Build 1 04"RTN","D GPTR0",3,0 ) ;;ADL;Up date for C SV Project ;;Mar 27,  2003"RTN", "DGPTR0",4 ,0) ;"RTN" ,"DGPTR0", 5,0) ; ICD XCODE APIs  - #5699"R TN","DGPTR 0",6,0) ;  SDCO22 API s - #1579" RTN","DGPT R0",7,0) ; "RTN","DGP TR0",8,0)  ; -- setup  control d ata"RTN"," DGPTR0",9, 0) ; ssn"R TN","DGPTR 0",10,0) S  X=$P(DG10 ,U,9),Y=$S ($E(X,10)= "P":"P",1: " ")_$E(X_ "          ",1,9)"RTN ","DGPTR0" ,11,0) ; - - adm d/t" RTN","DGPT R0",12,0)  S X=$P($P( DG0,U,2)," ."),Y=Y_$E (X,4,5)_$E (X,6,7)_$E (X,2,3)_$E ($P($P(DG0 ,U,2),".", 2)_"0000", 1,4)"RTN", "DGPTR0",1 3,0) ; --  facility # "RTN","DGP TR0",14,0)  S L=3,X=D G0,Z=3 D E NTER S Y=Y _$E($P(X,U ,5)_"   ", 1,3)"RTN", "DGPTR0",1 5,0) S DGH EAD=Y,Y="     "_Y D H EAD^DGPTR1 "RTN","DGP TR0",16,0)  ;"RTN","D GPTR0",17, 0)101 ; --  setup 101  transmiss ion"RTN"," DGPTR0",18 ,0) ; cont rol data a nd name"RT N","DGPTR0 ",19,0) S  Y=$S(T1:"C ",1:"N")_" 101"_DGHEA D S Y=Y_$$ PTFNMFT($P (DG10,U))" RTN","DGPT R0",20,0)  ; source o f admissio n"RTN","DG PTR0",21,0 ) S Y=Y_$S ($D(^DIC(4 5.1,+DG101 ,0)):$J($P (^(0),U,1) ,2),1:"  " )"RTN","DG PTR0",22,0 ) ; xfring  fac and s uffix"RTN" ,"DGPTR0", 23,0) S L= 3,X=DG101, Z=5 D ENTE R S Y=Y_$E ($P(X,U,6) _"   ",1,3 )"RTN","DG PTR0",24,0 ) ; source  of paymen t"RTN","DG PTR0",25,0 ) S Y=Y_$S ("A0"[$P(D G0,U,5):"  ",1:$J($P( DG101,U,3) ,1))"RTN", "DGPTR0",2 6,0) ;POW  Location"R TN","DGPTR 0",27,0) S  Y=Y_$S($P (DG52,U,5) ="N":1,$P( DG52,U,5)' ="Y":3,$P( DG52,U,6)> 0&($P(DG52 ,U,6)<7):3 +$P(DG52,U ,6),$P(DG5 2,U,6)>6&( $P(DG52,U, 6)<9):$C($ P(DG52,U,6 )+58),1:"  ")"RTN","D GPTR0",28, 0) ;marita l status,  sex"RTN"," DGPTR0",29 ,0) S Y=Y_ $S($D(^DIC (11,+$P(DG 10,U,5),0) ):$E(^(0), 1),1:" ")_ $J($P(DG10 ,U,2),1)"R TN","DGPTR 0",30,0) ;   date of  birth"RTN" ,"DGPTR0", 31,0) S DG DOB=$P(DG1 0,U,3)\1,Y =Y_$E(DGDO B,4,5)_$E( DGDOB,6,7) _(1700+$E( DGDOB,1,3) )"RTN","DG PTR0",32,0 ) ; period  of servic e"RTN","DG PTR0",33,0 ) S DGPOS= $S($D(^DIC (21,+$P(DG 32,U,3),0) ):$P(^(0), U,3),1:"") "RTN","DGP TR0",34,0)  I $D(^DGP M(+$O(^DGP M("APTF",J ,0)),"ODS" )),+^("ODS ") S DGPOS =6"RTN","D GPTR0",35, 0) ;-- if  non vet ad mitting el igibility  make POS 9 "RTN","DGP TR0",36,0)  S DGPOS=$ $CKPOS^DGP TUTL($P($G (^DGPT(PTF ,101)),U,8 ),DGPOS)"R TN","DGPTR 0",37,0) S  X=DGPOS,Z =1,L=2 D E NTER"RTN", "DGPTR0",3 8,0) ; age nt orange" RTN","DGPT R0",39,0)  S G=" " S  DGAO=$P(DG 321,U,2) S :DGPOS=7 G =$S($P(DG3 21,U)'="Y" :1,DGAO="N ":2,DGAO=" Y":3,1:4)  S:(DGAO="Y ")&($P(DG3 21,U,13)=" K") G=5"RT N","DGPTR0 ",40,0) ;  rad exposu re"RTN","D GPTR0",41, 0) S E=" "  I "^0^2^4 ^5^7^8^Z^" [(U_DGPOS_ U) S DGNT= $P(DG321,U ,12),E=$S( $P(DG321,U ,3)'="Y":1 ,DGNT="N": 2,DGNT="T" :3,DGNT="B ":4,1:" ") "RTN","DGP TR0",42,0)  S Y=Y_G_E  K DGPOS,G ,E"RTN","D GPTR0",43, 0) ; state  code"RTN" ,"DGPTR0", 44,0) S X= $S($D(^DIC (5,+$P(DG1 1,U,5),0)) :^(0),1:"" ),L=2,Z=3  D ENTER0"R TN","DGPTR 0",45,0) ;  county co de"RTN","D GPTR0",46, 0) S X=$S( $D(^DIC(5, +$P(DG11,U ,5),1,+$P( DG11,U,7), 0)):^(0),1 :""),L=3,Z =3 D ENTER 0"RTN","DG PTR0",47,0 ) ; zip co de"RTN","D GPTR0",48, 0) S X=DG1 1,Z=6,L=5  D ENTER"RT N","DGPTR0 ",49,0) ;  means test "RTN","DGP TR0",50,0)  S Y=Y_$S( $P(DG70,U, 26)="Y":"A S",1:$E($P (DG0,U,10) _"  ",1,2) )"RTN","DG PTR0",51,0 ) ; income "RTN","DGP TR0",52,0)  I $L($P(D G101,U,7)) >6 S Y=Y_" 999999""RT N","DGPTR0 ",53,0) E   S X=DG101 ,Z=7,L=6 D  ENTER0"RT N","DGPTR0 ",54,0) ;M ST"RTN","D GPTR0",55, 0) S X=$$G ETSTAT^DGM STAPI(+DG0 ) S Y=Y_$S (X<0:"U",1 :$P(X,"^", 2))"RTN"," DGPTR0",56 ,0) ;Comba t Vet"RTN" ,"DGPTR0", 57,0) S X= $$CVEDT^DG CV(+DG0,$P (DG0,"^",2 )) S Y=Y_$ S((+X)>0:1 ,1:0)"RTN" ,"DGPTR0", 58,0) S X= $P(X,"^",2 )_"        " S Y=Y_$E (X,4,5)_$E (X,6,7)_$E (X,2,3)"RT N","DGPTR0 ",59,0) ;P roject 112 /SHAD"RTN" ,"DGPTR0", 60,0) S X= $$SHAD^SDC O22(+DG0)  S Y=Y_$S(( +X)>0:1,1: 0)"RTN","D GPTR0",61, 0) ;Emerge ncy Respon se Indicat or"RTN","D GPTR0",62, 0) S X=$$E MGRES^DGUT L(+DG0) S  Y=Y_$S("^K ^"[(U_X_U) :X,1:" ")" RTN","DGPT R0",63,0)  ;Country C ode"RTN"," DGPTR0",64 ,0) S X=$$ GET1^DIQ(7 79.004,$P( DG11,U,10) _",",.01), Z=1,L=3 D  ENTER"RTN" ,"DGPTR0", 65,0) ;Cam p Lejeune  AF - RSD 2 .6.5.6 PTF  TRANSMISS ION via Ma ilMan DG*5 .3*914"RTN ","DGPTR0" ,66,0) S X =$$GETCL^D GUTL3(+DG0 )"RTN","DG PTR0",67,0 ) S Y=Y_$S (X=1:1,X=0 :0,1:" ")" RTN","DGPT R0",68,0)  D FILL^DGP TR2,SAVE"R TN","DGPTR 0",69,0) ; I T1 S Y=$ E(Y,1,52)_ " "_$E(Y,5 4,125)"RTN ","DGPTR0" ,70,0) I T 1 S $E(Y,5 3)=" " ;se ts $E(Y,53 )=" " if c ensus, but  why after  it is sav ed?"RTN"," DGPTR0",71 ,0) ;"RTN" ,"DGPTR0", 72,0)P401  ; -- setup  401P tran saction"RT N","DGPTR0 ",73,0) G  401:'$D(^D GPT(J,"401 P"))!(T1)  S DG41=^(" 401P"),Y=$ S(T1:"C",1 :"N")_"401 "_DGHEAD_" P"_"            ""RTN ","DGPTR0" ,74,0) N E FFDATE,IMP DATE,DGPTD AT D EFFDA TE^DGPTIC1 0(J)"RTN", "DGPTR0",7 5,0) S DG4 1=$S($D(^D GPT(J,"401 P")):^("40 1P"),1:"") "RTN","DGP TR0",76,0)  S L=1 F K =1:1:5 S:' $P(DG41,U, K) DG41=$P (DG41,U,1, K-1)_U_$P( DG41,U,K+1 ,99),K=K-1  S L=L+1 Q :L=5"RTN", "DGPTR0",7 7,0) F I=1 :1:5 S DGP TTMP=$$ICD DATA^ICDXC ODE("PROC" ,+$P(DG41, U,I),EFFDA TE,"I"),Y= Y_$S(+DGPT TMP>0:$J($ P($P(DGPTT MP,U,2),". ",1),2)_$E ($P($P(DGP TTMP,U,2), ".",2)_"    ",1,3),1: "     ")_"   ""RTN"," DGPTR0",78 ,0) K DGPT EDT"RTN"," DGPTR0",79 ,0) I $E(Y ,40)'=" "  D FILL^DGP TR2,SAVE"R TN","DGPTR 0",80,0) ; "RTN","DGP TR0",81,0) 401 ; -- s etup 401 t ransaction s"RTN","DG PTR0",82,0 ) G 501:'$ D(^DGPT(J, "S")) K ^U TILITY($J, "S") S I=0 "RTN","DGP TR0",83,0) SUR ;"RTN" ,"DGPTR0", 84,0) S I= $O(^DGPT(J ,"S",I)) G  501:'I S  DGSUR=^(I, 0),DGAUX=$ S($D(^DGPT (J,"S",I,3 00)):^(300 ),1:"") G  SUR:'DGSUR "RTN","DGP TR0",85,0)  G SUR:DGS UR<T1!(DGS UR>T2) S D GSUD=+^(0) \1,^UTILIT Y($J,"S",D GSUD)=$S($ D(^UTILITY ($J,"S",DG SUD)):^(DG SUD),1:0)+ 1,F=$S(DGS UD<2871000 :0,1:1)"RT N","DGPTR0 ",86,0) I  ^UTILITY($ J,"S",DGSU D)>$S(F:3, 1:2) D  I  Y'=1 S DGE RR=1 Q"RTN ","DGPTR0" ,87,0) .W  !,"**There  are more  than ",$S( F:"three", 1:"two"),"  surgeries  on the sa me date**" "RTN","DGP TR0",88,0)  .S DIR(0) ="Y",DIR(" B")="YES", DIR("A")=" OK to cont inue?" D ^ DIR K DIR" RTN","DGPT R0",89,0)  S Y=$S(T1: "C",1:"N") _"401"_DGH EAD_$E(DGS UD,4,5)_$E (DGSUD,6,7 )_$E(DGSUD ,2,3)_$E($ P(+DGSUR," .",2)_"000 0",1,4)_$S ($D(^DIC(4 5.3,+$P(DG SUR,U,3),0 )):$P(^(0) ,U,1),1:"   ")"RTN"," DGPTR0",90 ,0) S L=1, X=DGSUR F  Z=4:1:7 D  ENTER"RTN" ,"DGPTR0", 91,0) N EF FDATE,IMPD ATE,DGPTDA T D EFFDAT E^DGPTIC10 (J)"RTN"," DGPTR0",92 ,0) S L=1  F K=8:1:12  S:'$P(DGS UR,U,K) DG SUR=$P(DGS UR,U,1,K-1 )_U_$P(DGS UR,U,K+1,9 9),K=K-1 S  L=L+1 Q:L =5"RTN","D GPTR0",93, 0) F K=8:1 :12 S DGPT TMP=$$ICDD ATA^ICDXCO DE("PROC", +$P(DGSUR, U,K),EFFDA TE,"I"),Y= Y_$S(+DGPT TMP>0:$J($ P($P(DGPTT MP,U,2),". ",1),2)_$E ($P($P(DGP TTMP,U,2), ".",2)_"    ",1,3),1: "     ")_"   ""RTN"," DGPTR0",94 ,0) ;"RTN" ,"DGPTR0", 95,0) ;--  att phy"RT N","DGPTR0 ",96,0) S  Y=Y_"          ""RTN" ,"DGPTR0", 97,0) ;--  additional  ptf quest ion"RTN"," DGPTR0",98 ,0) ;send  null, if d isch date> inactive d ate. DG/72 9"RTN","DG PTR0",99,0 ) I +$P($G (^DIC(45.8 8,1,0)),U, 3) S DGAUX =$S((+$G(^ DGPT(J,70) )<$P(^DIC( 45.88,1,0) ,U,3)):DGA UX,1:"")"R TN","DGPTR 0",100,0)  S Y=Y_$E($ P(DGAUX,U) _" ")"RTN" ,"DGPTR0", 101,0) K D GAUX"RTN", "DGPTR0",1 02,0) D FI LL^DGPTR2, SAVE G SUR "RTN","DGP TR0",103,0 )501 G 501 ^DGPTR2"RT N","DGPTR0 ",104,0) Q "RTN","DGP TR0",105,0 )ENTER S Y =Y_$J($P(X ,U,Z),L)"R TN","DGPTR 0",106,0)  Q"RTN","DG PTR0",107, 0)ENTER0 S  Y=Y_$S($P (X,U,Z)]"" :$E("00000 0",$L($P(X ,U,Z))+1,L )_$P(X,U,Z ),1:$J($P( X,U,Z),L)) "RTN","DGP TR0",108,0 ) Q"RTN"," DGPTR0",10 9,0)SAVE ; save segme nt to Mail Man messag e and ^TMP ("AEDIT",$ J), if dat a is valid "RTN","DGP TR0",110,0 ) D SAVE^D GPTR2"RTN" ,"DGPTR0", 111,0)Q Q" RTN","DGPT R0",112,0) DGNAM S X= DGNAM I X? .E.P F I=1 :1:$L(X) S  Z=$E(X,I)  Q:Z=","   S:Z?.P&(Z] "") X=$E(X ,1,I-1)_$E (X,I+1,$L( X)),I=I-1  Q:X'?.E.P" RTN","DGPT R0",113,0)  I X?.E.L  D UP^DGHEL P"RTN","DG PTR0",114, 0) S DGNAM =X"RTN","D GPTR0",115 ,0) Q"RTN" ,"DGPTR0", 116,0) ;"R TN","DGPTR 0",117,0)P TFNMFT(DG1 0) ;this f unction wi ll format  the name o f the pati ent for"RT N","DGPTR0 ",118,0) ;  transmiss ion of the  101 recor d to Austi n. In addi tion, this "RTN","DGP TR0",119,0 ) ; functi on will be  used by O PC so that  the forma t will be  consistent "RTN","DGP TR0",120,0 ) ; for OP C and PTF. "RTN","DGP TR0",121,0 ) ;  INPUT  :   DG10  - .01 fiel d from the  patient r ecord."RTN ","DGPTR0" ,122,0) ;   OUTPUT:    name in t he format  proper for mat."RTN", "DGPTR0",1 23,0) ;         A = < 12 - chara cters of l ast name p added with  blanks>"R TN","DGPTR 0",124,0)  ;        B  = <1  - f irst initi al of fist  name>"RTN ","DGPTR0" ,125,0) ;         C =  <1  - fir st initial  of middle  name>"RTN ","DGPTR0" ,126,0) ;       retur ns :ABC <1 4 - charac ters>"RTN" ,"DGPTR0", 127,0) N X ,I"RTN","D GPTR0",128 ,0) S DGNA M=DG10 D D GNAM"RTN", "DGPTR0",1 29,0) Q $E ($P(DGNAM, ",",1)_"            " ,1,12)_$J( $E($P(DGNA M,",",2),1 ),1)_$J($E ($P($P(DGN AM,",",2), " ",2),1), 1)"RTN","D GPTR1")0^6 6^B3156990 6"RTN","DG PTR1",1,0) DGPTR1 ;AL B/MTC - PT F VERIFICA TION ;01 M AR 91 @080 0"RTN","DG PTR1",2,0)  ;;5.3;Reg istration; **58,247,3 38,342,423 ,415,565,6 78,696,729 ,781,664,8 17,850,914 **;Aug 13,  1993;Buil d 104"RTN" ,"DGPTR1", 3,0)START  ;"RTN","DG PTR1",4,0)  S T=$E(Y, 2,3),T=$S( T=40&($E(Y ,28)="P"): "P40",1:T) "RTN","DGP TR1",5,0)  S ERR=$P($ T(@("T"_T) ),";;",2,9 99),W=$P($ T(@(T)),"; ;",2,999), F=31 D L"R TN","DGPTR 1",6,0) ;  DG*5.3*914  with addi tion of CL V data, 10 1 now exce eds 245 by tes so spl it 101 int o 2 pieces "RTN","DGP TR1",7,0)  I T=10 S E RR=$P($T(T 101),";;", 2,999),W=$ P($T(101), ";;",2,999 ),F=100 D  L"RTN","DG PTR1",8,0)  I T=70 S  ERR=$P($T( T701),";;" ,2,999),W= $P($T(701) ,";;",2,99 9),F=72 D  L"RTN","DG PTR1",9,0)  D @("D"_T ) Q"RTN"," DGPTR1",10 ,0) K DGFI LL"RTN","D GPTR1",11, 0) Q"RTN", "DGPTR1",1 2,0) ;"RTN ","DGPTR1" ,13,0)L ;" RTN","DGPT R1",14,0)  N DGFOR S  DGFOR=$S($ $FORIEN^DG ADDUTL($P( DG11,U,10) )<1:0,1:1)  ;set fore ign countr y flag =1,  else, set  as domest ic"RTN","D GPTR1",15, 0) F H=1:1  S DGO=$P( W,U,H) Q:' DGO  D"RTN ","DGPTR1" ,16,0) . F  Z=1:1:$P( DGO,";",3)  D"RTN","D GPTR1",17, 0) .. S DG L=DGLOGIC( +DGO)"RTN" ,"DGPTR1", 18,0) .. S  X=$E(Y,F) "RTN","DGP TR1",19,0)  .. D @("E RR:"_DGL)  S F=F+1"RT N","DGPTR1 ",20,0) Q" RTN","DGPT R1",21,0)  ;"RTN","DG PTR1",22,0 )T10 ;;1:N AME^2:SOUR CE OF ADM^ 3:TRANS FA C.^4:SOURC E OF PAY^5 :POW^6:MAR ITAL ST^7: SEX^8:DOB^ 9:POS^10:V IETNAM^11: ION RADIAT ION^12:RES IDENCE^13: MEANS TEST ^14:INCOME ^15:MST^16 :COMBAT VE T^17:CV EN D DT^18:PR OJ 112/SHA D^19:ERI^2 0:COUNTRY" RTN","DGPT R1",23,0)  ;"RTN","DG PTR1",24,0 )T101 ;;1: CAMP LEJEU NE^"RTN"," DGPTR1",25 ,0) ;T101  is part 2  of T10"RTN ","DGPTR1" ,26,0)T70  ;;1:DT OF  DISP.^2:DI SCH BD SEC ^3:TYPE OF  DIS^4:OUT  TREAT^5:V A AUS^6:PL  OF DIS^7: REC FAC^8: ASIH DAYS^ 9:NOT USED ^10:C&P ST AT^11:PDXL S^12:ONLY  DX^13:PHY  MPCR"RTN", "DGPTR1",2 7,0) ;T701  is part 2  of T70"RT N","DGPTR1 ",28,0)T70 1 ;;1:PHY  SPEC^2:%SC ^3:LEGION^ 4:SUICIDE^ 5:DRUG^6:A XIS-IV^7:A XIS-V^8:SC ^9:EXP^10: MST^11:HNC ^12:ETHNIC ITY^13:RAC E^14:COMBA T VET^15:P ROJ 112/SH AD^16:ASIH ^17:CAMP L EJEUNE"RTN ","DGPTR1" ,29,0) ;"R TN","DGPTR 1",30,0)T5 0 ;;1:DT O F MVMT^2:L OSING BD S EC MPCR^3: LOSING BD  SEC^4:LEAV E DAYS^5:P ASS DAYS^6 :SCI^7:DIA G^8:DOCTOR 'S SSN^9:P HY MPCR^10 :PHY SPEC^ 11:DISCHAR GE STAT^^^ ^^16:LEGIO N^17:SUICI DE^18:DRUG ^19:AXIS-I V^20:AXIS- V^21:SC^22 :EXP^23:MS T^24:HNC"R TN","DGPTR 1",31,0) ; "RTN","DGP TR1",32,0) T53 ;;1:DA TE OF PHYS ICAL MOVEM ENT^2:LOSI NG PHYSICA L MPCR^3:L OSING PHYS ICAL SPECI ALTY^4:TR  SPECIALTY  MPCR^5:TR  SPECIALTY^ 6:LEAVE DA YS^7:PASS  DAYS^8:DOC TOR'S SSN  (NOT USED) "RTN","DGP TR1",33,0)  ;"RTN","D GPTR1",34, 0)T40 ;;1: DATE OF SU RGERY^2:SU RG SPEC.^3 :CAT CHIEF  SURGEON^4 :CAT FIRST  ASS^5:ANE ST. TECH.^ 6:SOURCE O F PAY^7:OP  CODE^8:DO CTOR'S SSN  (NOT USED )^^^^^13:T RANSPLANT  STATUS"RTN ","DGPTR1" ,35,0) ;"R TN","DGPTR 1",36,0)TP 40 ;;1:OP  CODE"RTN", "DGPTR1",3 7,0) ;"RTN ","DGPTR1" ,38,0)T60  ;;1:DATE O F PROCEDUR E^2:LOSING  BD SEC^3: DIALYSIS T YPE^4:NUMB ER OF TREA TMENTS^5:P ROCEDURE C ODE"RTN"," DGPTR1",39 ,0) ;"RTN" ,"DGPTR1", 40,0)LOGIC  ;;X'?.N^X '?.A&(X'="  ")^X'=" " ^X'?.N&(X' =" ")^X'?. A&(X'=" ") ^0^X'?.N&( X'="X")^X' =" "&(X'=" P")^X="E"^ X="Y"^X="  "^X'="A"&( X'=" ")^(X '?.A)&(X'? .N)&(X'="  ")^(X'?.AN )&('$P(DG0 ,U,4))^((T 1)&(X'=" " ))!(('T1)& (X'?.AN)&( '$P(DG0,U, 4)))"RTN", "DGPTR1",4 1,0) ;;(X' ?.AN)^'$D( DGFOR)&(X' ?.N)^'$D(D GFOR)&X'?. N&(X'="X") "RTN","DGP TR1",42,0)  ;;END"RTN ","DGPTR1" ,43,0) ;"R TN","DGPTR 1",44,0) ;  edit chec k# ; edit  field ; #  x check pr eformed ;  display er ror name # "RTN","DGP TR1",45,0) 10 ;;6;;12 ;1^2;1;1;1 ^5;1;1;1^1 ;2;1;2^2;2 ;1;2^4;3;3 ;3^6;;3;3^ 4;4;1;4^6; 5;1;5^2;6; 1;6^2;7;1; 7^1;8;8;8^ 6;;1;9^11; 9;1;9^4;10 ;1;10^4;10 ;1;11^17;1 1;5;12^18; 11;5;12^2; 12;1;13^6; ;1;13^1;;6 ;14^2;;1;1 5^1;;1;16^ 4;;6;17^1; ;1;18^5;;1 ;19^5;;3;2 0"RTN","DG PTR1",46,0 ) ;"RTN"," DGPTR1",47 ,0)101 ;;4 ;;1;1^"RTN ","DGPTR1" ,48,0)70 ; ;1;1;10;1^ 13;2;2;2^1 ;3;1;3^4;4 ;1;4^4;5;1 ;5^6;;1;6^ 4;7;3;7^6; ;3;7^4;8;3 ;8^6;9;1;9 ^1;10;1;10 ^9;11;1;11 ^11;11;2;1 1^6;;3;11^ 10;11;1;11 ^6;;1;12^1 5;;6;13"RT N","DGPTR1 ",49,0) ;7 01 is part  2 of 70"R TN","DGPTR 1",50,0)70 1 ;;15;;2; 1^1;;3;2^4 ;;1;3^4;;1 ;4^12;;1;5 ^4;;3;5^4; ;1;6^4;;4; 7^4;;1;8^5 ;;3;9^5;;1 ;10^5;;1;1 1^13;12;2; 12^13;13;1 2;13^5;;1; 14^5;;1;15 ^6;;3;16^5 ;;1;17"RTN ","DGPTR1" ,51,0) ;"R TN","DGPTR 1",52,0)50  ;;1;1;10; 1^1;;6;2^1 6;3;2;3^1; 4;3;4^1;5; 3;5^6;;1;6 ^11;7;3;7^ 6;;32;7^6; ;9;8^14;;6 ;9^14;;2;1 0^6;;1;11^ 4;;1;16^4; ;1;17^12;; 1;18^4;;3; 18^4;;1;19 ^4;;4;20^4 ;;1;21^5;; 3;22^5;;1; 23^5;;1;24 "RTN","DGP TR1",53,0)  ;"RTN","D GPTR1",54, 0)53 ;;1;; 10;1^1;;6; 2^13;;2;3^ 1;;6;4^13; ;2;5^1;;3; 6^1;;3;7^3 ;;9;8^3;;5 4;"RTN","D GPTR1",55, 0) ;"RTN", "DGPTR1",5 6,0)40 ;;1 ;1;10;1^1; 2;2;2^11;3 ;1;3^4;4;1 ;4^6;5;1;5 ^4;6;1;6^1 1;7;2;7^6; ;3;7^3;7;2 ;7^6;;5;7^ 3;7;2;7^6; ;5;7^3;7;2 ;7^6;;5;7^ 3;7;2;7^6; ;5;7^3;7;2 ;7^3;;9;8^ 4;;1;13^3; ;34;"RTN", "DGPTR1",5 7,0) ;"RTN ","DGPTR1" ,58,0)P40  ;;8;;1;^3; ;11;^11;1; 2;1^6;;3;1 ^3;1;2;1^6 ;;5;1^3;;2 ;1^6;;5;1^ 3;;2;1^6;; 5;1^3;;2;1 ^6;;5;1^3; ;2;1^3;;48 "RTN","DGP TR1",59,0)  ;"RTN","D GPTR1",60, 0)60 ;;1;1 ;10;1^13;2 ;2;2^4;3;1 ;3^4;4;3;4 ^11;5;3;5^ 6;;32;5^3; ;44"RTN"," DGPTR1",61 ,0) ;"RTN" ,"DGPTR1", 62,0)ERR ; "RTN","DGP TR1",63,0)  S DGERR=1 "RTN","DGP TR1",64,0)  W !,T,$S( T["H":" ", 1:$E(Y,4)) ,"  ""RTN" ,"DGPTR1", 65,0) W:"4 5"[$E(T,1)  $E(Y,31,3 2),"-",$E( Y,33,34)," -",$E(Y,35 ,36),"@",$ E(Y,37,40) "RTN","DGP TR1",66,0)  W ?25,$P( $P(ERR,U,$ P(DGO,";", 4)),":",2) ,?40,"COL. ",F,"  VAL UE: ",$S($ E(Y,F)=" " :"BLANK",1 :$E(Y,F))" RTN","DGPT R1",67,0)  S I=$S('$D (I):1,I>0: I,1:1),^(I )=$S($D(^U TILITY("DG ",$J,T_$S( T["H":"",1 :$E(Y,4)), I)):^(I),1 :U) I $P(D GO,";",2), ^(I)'[(U_$ P(DGO,";", 2)_U) S ^( I)=^(I)_$P (DGO,";",2 )_U"RTN"," DGPTR1",68 ,0) Q"RTN" ,"DGPTR1", 69,0) ;"RT N","DGPTR1 ",70,0)D10  ;"RTN","D GPTR1",71, 0) I $E(Y, 66)="Z" S  (F,H)=68,W ="11;10;1; 10" D L"RT N","DGPTR1 ",72,0) Q" RTN","DGPT R1",73,0)  ;"RTN","DG PTR1",74,0 )D40 Q"RTN ","DGPTR1" ,75,0)DP40  Q"RTN","D GPTR1",76, 0)D70 I "4 67"'[$E(Y, 43) S F=44 ,W="4;4;1; 4^1;5;1;5^ 11;6;1;6"  D L"RTN"," DGPTR1",77 ,0) Q"RTN" ,"DGPTR1", 78,0)D50 I  "A0"[$P(D G0,U,5)!(" A4"[$P(DG0 ,U,5))!('$ D(^DGPT(J, 70))) S W= "11;6;1;6" ,F=55 D L" RTN","DGPT R1",79,0)  I $D(^DGPT (J,70)),$S (T1:1,1:+^ (70)>28710 00) S W="1 1;6;1;6",F =55 D L"RT N","DGPTR1 ",80,0) I  $E(Y,4)=1  S W="9;7;1 ;7",F=56 D  L"RTN","D GPTR1",81, 0) I I=1,' T1 S W="1; 11;1;11",F =108 D L"R TN","DGPTR 1",82,0) Q "RTN","DGP TR1",83,0) D53 Q"RTN" ,"DGPTR1", 84,0)D60 I  $E(Y,43)  S F=44,W=" 1;4;3;4" D  L"RTN","D GPTR1",85, 0) Q"RTN", "DGPTR1",8 6,0)HEAD S  ERR="1:SS N^2:ADMISS ION DATE^3 :FACILITY  #",W="8;1; 1;1^1;1;9; 1^1;2;10;2 ^1;3;3;3^6 ;;3;3",F=5 ,T="HEADER " D LOG"RT N","DGPTR1 ",87,0) D  L"RTN","DG PTR1",88,0 ) Q"RTN"," DGPTR1",89 ,0)LOG ;pl ace DGLOGI C in array  in order  to add mor e logic te sts ;DG*5. 3*664"RTN" ,"DGPTR1", 90,0) K DG LOGIC ;S D GLOGIC=$P( $T(LOGIC), ";;",2)"RT N","DGPTR1 ",91,0) N  LOGX,LOGI, LOGCNT,II, XX"RTN","D GPTR1",92, 0) S LOGI= 0,LOGCNT=1 "RTN","DGP TR1",93,0)  F LOGI=0: 1 S LOGX=$ P($T(LOGIC +LOGI),";; ",2) Q:LOG X="END"  F  II=1:1 S  XX=$P(LOGX ,U,II) Q:X X=""  S DG LOGIC(LOGC NT)=XX,LOG CNT=LOGCNT +1"RTN","D GPTR1",94, 0) Q"RTN", "DGPTR1",9 5,0)CEN S  T=70,ERR=$ P($T(T70), ";;",2),W= $P($T(70), ";;",2,999 ),W="13;9; 1;9"_$P(W, "13;9;1;9" ,2,999),F= 56 D L"RTN ","DGPTR1" ,96,0) S E RR=$P($T(T 701),";;", 2),W=$P($T (701),";;" ,2,999),F= 72 D L"RTN ","DGPTR1" ,97,0) Q"R TN","DGPTR 4")0^24^B2 2236456"RT N","DGPTR4 ",1,0)DGPT R4 ;ALB/JD S/MJK/MTC/ ADL/TJ/BOK ,HIOFO/FT  - PTF TRAN SMISSION ; 5/11/15 4: 52pm"RTN", "DGPTR4",2 ,0) ;;5.3; Registrati on;**338,4 23,415,510 ,565,645,7 29,664,850 ,884,914** ;Aug 13, 1 993;Build  104"RTN"," DGPTR4",3, 0) ;"RTN", "DGPTR4",4 ,0) ; ICDX CODE APIs  - #5699"RT N","DGPTR4 ",5,0) ;"R TN","DGPTR 4",6,0)701  ; -- setu p 701 tran saction"RT N","DGPTR4 ",7,0) S Y =$S(T1:"C" ,1:"N")_"7 01"_DGHEAD ,DGDDX=$P( +DG70,".") _"       " ,Y=Y_$E(DG DDX,4,5)_$ E(DGDDX,6, 7)_$E(DGDD X,2,3)_$E( $P(+DG70," .",2)_"000 0",1,4)"RT N","DGPTR4 ",8,0) S X =DG70"RTN" ,"DGPTR4", 9,0) ;repl ace specia lty pointe r (ien) wi th ptf cod e (alpha-n umeric)"RT N","DGPTR4 ",10,0) N  DGARRX,DGA RRY ;DG729 "RTN","DGP TR4",11,0)  S DGARRX= $$TSDATA^D GACT(42.4, $P(X,U,2), .DGARRY)"R TN","DGPTR 4",12,0) S  $P(X,U,2) =$G(DGARRY (7))"RTN", "DGPTR4",1 3,0) S (L, Z)=2 D ENT ER0 K DGDD X"RTN","DG PTR4",14,0 ) S X=DG70  I "467"[( $P(X,U,3)\ 1) S Y=Y_$ P(X,U,3)_"          "  G J"RTN", "DGPTR4",1 5,0) S L=1  F Z=3:1:5  D ENTER"R TN","DGPTR 4",16,0) S  Y=Y_$S($D (^DIC(45.6 ,+$P(X,U,6 ),0)):$P(^ (0),U,2),1 :" "),L=3, Z=12 D ENT ER S Y=Y_$ E($P(X,U,1 3)_"   ",1 ,3)"RTN"," DGPTR4",17 ,0)J S L=3 ,Z=8 D ENT ER0"RTN"," DGPTR4",18 ,0) S Y=Y_ "X"_$J($P( DG70,U,9), 1)"RTN","D GPTR4",19, 0) N EFFDA TE,IMPDATE ,DGPTDAT D  EFFDATE^D GPTIC10(J) "RTN","DGP TR4",20,0)  S DGPTTMP =$$ICDDATA ^ICDXCODE( "DIAG",+$P (DG70,U,10 ),EFFDATE, "I")"RTN", "DGPTR4",2 1,0) S DGX LS=$S(+DGP TTMP>0&($P (DGPTTMP,U ,10)):$P(D GPTTMP,U,2 ),1:""),Y= Y_$S(DGXLS [".":$J($P (DGXLS,"." ,1),3)_$E( $P(DGXLS," .",2)_"    ",1,3),1:$ J(DGXLS,6) )_" ""RTN" ,"DGPTR4", 22,0) S L= $P(DG70,U, 16,24)_U_D G71 S DG70 2="""RTN", "DGPTR4",2 3,0) F K=1 :1:12 S DG PTTMP=$$IC DDATA^ICDX CODE("DIAG ",+$P(L,U, K),EFFDATE ,"I") I +D GPTTMP>0&( $P(DGPTTMP ,U,10)) S  DG702=DG70 2_$P(DGPTT MP,U,2)_U" RTN","DGPT R4",24,0)  S Y=Y_$S(D G702']"":" X",1:" ")" RTN","DGPT R4",25,0)  ; -- get p hy cdr @ d /c"RTN","D GPTR4",26, 0) S X="", Z=+$O(^DGP T(J,535,"A M",DG70-.0 000001)) I  $D(^DGPT( J,535,+$O( ^(Z,0)),0) ) S X=^(0) "RTN","DGP TR4",27,0)  ; -- set  phy cdr"RT N","DGPTR4 ",28,0) S  Z=$P(X,U,1 6) D CDR"R TN","DGPTR 4",29,0) ;  -- set ph y spec"RTN ","DGPTR4" ,30,0) ;re place spec ialty poin ter (ien)  with ptf c ode (alpha -numeric)" RTN","DGPT R4",31,0)  N DGARRX,D GARRY ;DG7 29"RTN","D GPTR4",32, 0) S DGARR X=$$TSDATA ^DGACT(42. 4,$P(X,U,2 ),.DGARRY) "RTN","DGP TR4",33,0)  S $P(X,U, 2)=$G(DGAR RY(7))"RTN ","DGPTR4" ,34,0) S L =2,Z=2 D E NTER0"RTN" ,"DGPTR4", 35,0) S X= $S($P(DG3, U)="Y":$$R TEN($P(DG3 ,U,2)),1:" 0"),L=3,Z= 1 D ENTER0 "RTN","DGP TR4",36,0)  ;-- addit ional ptf  questions" RTN","DGPT R4",37,0)  S DGAUX=$S ($D(^DGPT( J,300)):^( 300),1:"") "RTN","DGP TR4",38,0)  D ADDQUES "RTN","DGP TR4",39,0)  K DGAUX,D GDRUG"RTN" ,"DGPTR4", 40,0) ;--  sc,ao,ir,e c question s"RTN","DG PTR4",41,0 ) S X=DG70 "RTN","DGP TR4",42,0)  ;-- sc"RT N","DGPTR4 ",43,0) S  Y=Y_$E($P( DG70,U,25) _" ")"RTN" ,"DGPTR4", 44,0) ;--  ao"RTN","D GPTR4",45, 0) S Y=Y_$ E($P(DG70, U,26)_" ") "RTN","DGP TR4",46,0)  ;-- ir"RT N","DGPTR4 ",47,0) S  Y=Y_$E($P( DG70,U,27) _" ")"RTN" ,"DGPTR4", 48,0) ;--  SW Asia co nditions/e c"RTN","DG PTR4",49,0 ) S Y=Y_$E ($P(DG70,U ,28)_" ")" RTN","DGPT R4",50,0)  ;-- mst"RT N","DGPTR4 ",51,0) S  Y=Y_$E($P( DG70,U,29) _" ")"RTN" ,"DGPTR4", 52,0) ;--  Head/Neck  CA"RTN","D GPTR4",53, 0) S Y=Y_$ E($P(DG70, U,30)_" ") "RTN","DGP TR4",54,0)  D ETHNIC" RTN","DGPT R4",55,0)  D RACE"RTN ","DGPTR4" ,56,0) ;Co mbat vet"R TN","DGPTR 4",57,0) S  Y=Y_$E($P (DG70,U,31 )_" ")"RTN ","DGPTR4" ,58,0) ;Pr oject 112/ SHAD"RTN", "DGPTR4",5 9,0) S Y=Y _$E($P(DG7 0,U,32)_"  ")"RTN","D GPTR4",60, 0) ;Camp L ejeune AF  - RSD 2.6. 5.6 PTF TR ANSMISSION  via MailM an DG*5.3* 914"RTN"," DGPTR4",61 ,0) ; 914  added 3 sp aces betwe en SHAD an d CLV for  a future A SIH projec t, Bed Con trol"RTN", "DGPTR4",6 2,0) S $E( Y,113)=$E( $P(DG70,U, 33)_" ")"R TN","DGPTR 4",63,0) D  FILL^DGPT R2 ;pad to  125 chara cters"RTN" ,"DGPTR4", 64,0) I T1  F K=41:1: 55,65:1:73  S $E(Y,K) =" " ;send  spaces if  census"RT N","DGPTR4 ",65,0) I  T1 D CEN^D GPTR1 D:'D GERR SAVE7 0X Q"RTN", "DGPTR4",6 6,0) I 'T1  D SAVE"RT N","DGPTR4 ",67,0)702  ;"RTN","D GPTR4",68, 0) Q:DG702 ']"""RTN", "DGPTR4",6 9,0) S Y=" N702"_$E(Y ,5,40)"RTN ","DGPTR4" ,70,0) F K =1:1:12 S  F=$P(DG702 ,U,K),F=$P (F,".",1)_ $E($P(F,". ",2)_"   " ,1,3),F=F_ $E("       ",1,7-$L(F )),Y=Y_F"R TN","DGPTR 4",71,0) D  FILL^DGPT R2 ;pad to  125 chara cters"RTN" ,"DGPTR4", 72,0) I 'D GERR D SAV E70X"RTN", "DGPTR4",7 3,0) I DGE RR'>0 S DG ACNT=DGACN T+1,^TMP(" AEDIT",$J, $E(Y,1,4), DGACNT)=Y" RTN","DGPT R4",74,0)  S DG702=$P (DG702,U,6 ,9)"RTN"," DGPTR4",75 ,0) Q"RTN" ,"DGPTR4", 76,0) ;"RT N","DGPTR4 ",77,0)ENT ER S Y=Y_$ J($P(X,U,Z ),L)"RTN", "DGPTR4",7 8,0) Q"RTN ","DGPTR4" ,79,0) ;"R TN","DGPTR 4",80,0)EN TER0 S Y=Y _$S($P(X,U ,Z)]"":$E( "00000",$L ($P(X,U,Z) )+1,L)_$P( X,U,Z),1:$ J($P(X,U,Z ),L))"RTN" ,"DGPTR4", 81,0) Q"RT N","DGPTR4 ",82,0) ;" RTN","DGPT R4",83,0)S AVE ;valid ate data a nd save to  MailMan m essage & ^ TMP("AEDIT ",$J)"RTN" ,"DGPTR4", 84,0) D SA VE^DGPTR2" RTN","DGPT R4",85,0)Q  ;"RTN","D GPTR4",86, 0) Q"RTN", "DGPTR4",8 7,0)SAVE70 X ;pad wit h spaces,  set 383rd  character  & save to  MailMan me ssage."RTN ","DGPTR4" ,88,0) N D GY1,DGY2"R TN","DGPTR 4",89,0) D  FILL384^D GPTR2"RTN" ,"DGPTR4", 90,0) S DG Y1=$E(Y,1, 240),DGY2= $E(Y,241,3 84)"RTN"," DGPTR4",91 ,0) S ^XMB (3.9,DGXMZ ,2,DGCNT,0 )=DGY1,DGC NT=DGCNT+1 "RTN","DGP TR4",92,0)  S ^XMB(3. 9,DGXMZ,2, DGCNT,0)=D GY2,DGCNT= DGCNT+1"RT N","DGPTR4 ",93,0) Q" RTN","DGPT R4",94,0)  ;"RTN","DG PTR4",95,0 )CDR S Y=Y _$E($P(Z," .")_"0000" ,1,4)_$E($ P(Z,".",2) _"00",1,2) "RTN","DGP TR4",96,0)  Q"RTN","D GPTR4",97, 0)ADDQUES  ;-- additi onal PTF q uestions l oad record s for tran s 501/701" RTN","DGPT R4",98,0)  N DGADDQ"R TN","DGPTR 4",99,0) F  DGADDQ=2, 3,4 D  ;nu ll results  if discha rge>inacti ve date. D G/729"RTN" ,"DGPTR4", 100,0) . I  +$P($G(^D IC(45.88,D GADDQ,0)), U,3) S $P( DGAUX,U,DG ADDQ)=$S(( +$G(^DGPT( J,70))<$P( ^DIC(45.88 ,DGADDQ,0) ,U,3)):$P( DGAUX,U,DG ADDQ),1:"" )"RTN","DG PTR4",101, 0) S DGDRU G=$S($D(^D IC(45.61,+ $P(DGAUX,U ,4),0)):$P (^(0),U,2) ,1:"    ") "RTN","DGP TR4",102,0 ) S Y=Y_$E ($P(DGAUX, U,3)_" ")_ $E($P(DGAU X,U,2)_" " )_$J($P(DG DRUG,U),4) "RTN","DGP TR4",103,0 ) S Y=Y_$E ($P(DGAUX, U,5)_" ")" RTN","DGPT R4",104,0)  S DGT=0,X =$P(DGAUX, U,6) I X]" " S DGT=1, Z=1,L=2 D  ENTER0"RTN ","DGPTR4" ,105,0) I  'DGT S Y=Y _"  ""RTN" ,"DGPTR4", 106,0) S D GT=0,X=$P( DGAUX,U,7)  I X]"" S  DGT=1,Z=1, L=2 D ENTE R0"RTN","D GPTR4",107 ,0) I 'DGT  S Y=Y_"   ""RTN","DG PTR4",108, 0) Q"RTN", "DGPTR4",1 09,0)RTEN( X) ; This  function w ill round  X to the n earest mul tiple of t en."RTN"," DGPTR4",11 0,0) ; 0-4  ->DOWN; 5 -9->UP"RTN ","DGPTR4" ,111,0) Q  (X\10)*10+ $S(X#10>4: 10,1:0)"RT N","DGPTR4 ",112,0)ET HNIC ;-- E thnicity ( use first  active val ue)"RTN"," DGPTR4",11 3,0) N NOD E,NUM,ETHN IC,I,X"RTN ","DGPTR4" ,114,0) S  ETHNIC=""" RTN","DGPT R4",115,0)  S I=0"RTN ","DGPTR4" ,116,0) S  NUM=1"RTN" ,"DGPTR4", 117,0) F   S I=+$O(DG 06(I)) Q:' I  D  Q:NU M>1"RTN"," DGPTR4",11 8,0) .S NO DE=$G(DG06 (I,0))"RTN ","DGPTR4" ,119,0) .Q :('NODE)!( '$D(^DIC(1 0.2,+NODE, 0)))"RTN", "DGPTR4",1 20,0) .Q:$ $INACTIVE^ DGUTL4(+NO DE,2)"RTN" ,"DGPTR4", 121,0) .S  X=$$PTR2CO DE^DGUTL4( +NODE,2,4) "RTN","DGP TR4",122,0 ) .S ETHNI C=$S(X="": " ",1:X)"R TN","DGPTR 4",123,0)  .S X=$$PTR 2CODE^DGUT L4(+$P(NOD E,"^",2),3 ,4)"RTN"," DGPTR4",12 4,0) .S ET HNIC=ETHNI C_$S(X="": " ",1:X)"R TN","DGPTR 4",125,0)  .S NUM=NUM +1"RTN","D GPTR4",126 ,0) S Y=Y_ $S(ETHNIC= "":"  ",1: ETHNIC)"RT N","DGPTR4 ",127,0) Q "RTN","DGP TR4",128,0 )RACE ;--  Race (use  first 6 ac tive value s)"RTN","D GPTR4",129 ,0) N NODE ,NUM,RACE, I,X"RTN"," DGPTR4",13 0,0) S RAC E="""RTN", "DGPTR4",1 31,0) S I= 0"RTN","DG PTR4",132, 0) S NUM=1 "RTN","DGP TR4",133,0 ) F  S I=+ $O(DG02(I) ) Q:'I  D   Q:NUM>6"R TN","DGPTR 4",134,0)  .S NODE=$G (DG02(I,0) )"RTN","DG PTR4",135, 0) .Q:('NO DE)!('$D(^ DIC(10,+NO DE,0)))"RT N","DGPTR4 ",136,0) . Q:$$INACTI VE^DGUTL4( +NODE)"RTN ","DGPTR4" ,137,0) .S  X=$$PTR2C ODE^DGUTL4 (+NODE,1,4 )"RTN","DG PTR4",138, 0) .S RACE =RACE_$S(X ="":" ",1: X)"RTN","D GPTR4",139 ,0) .S X=$ $PTR2CODE^ DGUTL4(+$P (NODE,"^", 2),3,4)"RT N","DGPTR4 ",140,0) . S RACE=RAC E_$S(X="": " ",1:X)"R TN","DGPTR 4",141,0)  .S NUM=NUM +1"RTN","D GPTR4",142 ,0) S X=""  S $P(X,"  ",12)="""R TN","DGPTR 4",143,0)  S RACE=$S( RACE="":"   ",1:RACE) _X"RTN","D GPTR4",144 ,0) S Y=Y_ $E(RACE,1, 12)"RTN"," DGPTR4",14 5,0) Q"RTN ","DGPTRI0 ")0^25^B27 777148"RTN ","DGPTRI0 ",1,0)DGPT RI0 ;MJK/J S/ADL/TJ,I SF/GJW,HIO FO/FT - PT F TRANSMIS SION ;4/9/ 15 2:57pm" RTN","DGPT RI0",2,0)  ;;5.3;Regi stration;* *850,884,9 14**;Aug 1 3, 1993;Bu ild 104"RT N","DGPTRI 0",3,0) ;; ADL;Update  for CSV P roject;;Ma r 27, 2003 "RTN","DGP TRI0",4,0)  ;"RTN","D GPTRI0",5, 0) ; ICDXC ODE APIs -  5699"RTN" ,"DGPTRI0" ,6,0) ; SD CO22 APIs  - 1579"RTN ","DGPTRI0 ",7,0) ; X LFSTR APIs  - 10104"R TN","DGPTR I0",8,0) ; "RTN","DGP TRI0",9,0)  ; -- setu p control  data"RTN", "DGPTRI0", 10,0) ; ss n"RTN","DG PTRI0",11, 0) S X=$P( DG10,U,9), Y=$S($E(X, 10)="P":"P ",1:" ")_$ E(X_"          ",1,9) "RTN","DGP TRI0",12,0 ) ; -- adm  d/t"RTN", "DGPTRI0", 13,0) S X= $P($P(DG0, U,2),"."), Y=Y_$E(X,4 ,5)_$E(X,6 ,7)_$E(X,2 ,3)_$E($P( $P(DG0,U,2 ),".",2)_" 0000",1,4) "RTN","DGP TRI0",14,0 ) ; -- fac ility #"RT N","DGPTRI 0",15,0) S  L=3,X=DG0 ,Z=3 D ENT ER S Y=Y_$ E($P(X,U,5 )_"   ",1, 3)"RTN","D GPTRI0",16 ,0) S DGHE AD=Y,Y="     "_Y D HE AD^DGPTRI1 "RTN","DGP TRI0",17,0 ) ;"RTN"," DGPTRI0",1 8,0)101 ;  -- setup 1 01 transmi ssion"RTN" ,"DGPTRI0" ,19,0) ; c ontrol dat a and name "RTN","DGP TRI0",20,0 ) S $E(Y,1 ,30)=$S(T1 :"C",1:"N" )_"101"_DG HEAD"RTN", "DGPTRI0", 21,0) S $E (Y,31,44)= $$PTFNMFT( $P(DG10,U) )"RTN","DG PTRI0",22, 0) ; sourc e of admis sion - $E( Y,45,46)"R TN","DGPTR I0",23,0)  S $E(Y,45, 46)=$S($D( ^DIC(45.1, +DG101,0)) :$J($P(^(0 ),U,1),2), 1:"  ")"RT N","DGPTRI 0",24,0) ;  xfring fa c and suff ix - $E(Y, 47,49) & $ E(Y,50,52) "RTN","DGP TRI0",25,0 ) S L=3,X= DG101,Z=5  D FORMAT S  $E(Y,47,4 9)=DGVALUE  S $E(Y,50 ,52)=$E($P (X,U,6)_"    ",1,3)"R TN","DGPTR I0",26,0)  ; source o f payment  - $E(Y,53) "RTN","DGP TRI0",27,0 ) S $E(Y,5 3)=$S("A0" [$P(DG0,U, 5):" ",1:$ J($P(DG101 ,U,3),1))" RTN","DGPT RI0",28,0)  ;POW Loca tion $E(Y, 54)"RTN"," DGPTRI0",2 9,0) S $E( Y,54)=$S($ P(DG52,U,5 )="N":1,$P (DG52,U,5) '="Y":3,$P (DG52,U,6) >0&($P(DG5 2,U,6)<7): 3+$P(DG52, U,6),$P(DG 52,U,6)>6& ($P(DG52,U ,6)<9):$C( $P(DG52,U, 6)+58),1:"  ")"RTN"," DGPTRI0",3 0,0) ;mari tal status , sex - $E (Y,55) & $ E(Y,56)"RT N","DGPTRI 0",31,0) S  $E(Y,55,5 6)=$S($D(^ DIC(11,+$P (DG10,U,5) ,0)):$E(^( 0),1),1:"  ")_$J($P(D G10,U,2),1 )"RTN","DG PTRI0",32, 0) ;  date  of birth  - $E(Y,57, 64)"RTN"," DGPTRI0",3 3,0) S DGD OB=$P(DG10 ,U,3)\1,$E (Y,57,64)= $E(DGDOB,4 ,5)_$E(DGD OB,6,7)_(1 700+$E(DGD OB,1,3))"R TN","DGPTR I0",34,0)  S $E(Y,65) =" " ;blan k, not use d"RTN","DG PTRI0",35, 0) ; perio d of servi ce - $E(Y, 66)"RTN"," DGPTRI0",3 6,0) S DGP OS=$S($D(^ DIC(21,+$P (DG32,U,3) ,0)):$P(^( 0),U,3),1: "")"RTN"," DGPTRI0",3 7,0) I $D( ^DGPM(+$O( ^DGPM("APT F",J,0))," ODS")),+^( "ODS") S D GPOS=6"RTN ","DGPTRI0 ",38,0) ;- - if non v et admitti ng eligibi lity make  POS 9"RTN" ,"DGPTRI0" ,39,0) S D GPOS=$$CKP OS^DGPTUTL ($P($G(^DG PT(PTF,101 )),U,8),DG POS)"RTN", "DGPTRI0", 40,0) S X= DGPOS,Z=1, L=1 D FORM AT S $E(Y, 66)=DGVALU E"RTN","DG PTRI0",41, 0) ; agent  orange -  $E(Y,67)"R TN","DGPTR I0",42,0)  S G=" " S  DGAO=$P(DG 321,U,2) S :DGPOS=7 G =$S($P(DG3 21,U)'="Y" :1,DGAO="N ":2,DGAO=" Y":3,1:4)  S:(DGAO="Y ")&($P(DG3 21,U,13)=" K") G=5"RT N","DGPTRI 0",43,0) ;  rad expos ure - $E(Y ,68)"RTN", "DGPTRI0", 44,0) ;pat ch 884 - u se the cor rect numer ic codes ( from the D D)"RTN","D GPTRI0",45 ,0) S E="  " I "^0^2^ 4^5^7^8^Z^ "[(U_DGPOS _U) S (E,D GNT)=$P(DG 321,U,12)" RTN","DGPT RI0",46,0)  S $E(Y,67 ,68)=G_E K  DGPOS,G,E "RTN","DGP TRI0",47,0 ) ; state  code - $E( Y,69,70)"R TN","DGPTR I0",48,0)  S X=$S($D( ^DIC(5,+$P (DG11,U,5) ,0)):^(0), 1:""),L=2, Z=3 D FORM AT0 S $E(Y ,69,70)=DG VALUE0"RTN ","DGPTRI0 ",49,0) ;  county cod e - $E(Y,7 1,73)"RTN" ,"DGPTRI0" ,50,0) S X =$S($D(^DI C(5,+$P(DG 11,U,5),1, +$P(DG11,U ,7),0)):^( 0),1:""),L =3,Z=3 D F ORMAT0 S $ E(Y,71,73) =DGVALUE0" RTN","DGPT RI0",51,0)  ; zip cod e - $E(Y,7 4,78)"RTN" ,"DGPTRI0" ,52,0) S X =DG11,Z=6, L=5 D FORM AT S $E(Y, 74,78)=DGV ALUE"RTN", "DGPTRI0", 53,0) ; me ans test -  $E(Y,79,8 0)"RTN","D GPTRI0",54 ,0) S $E(Y ,79,80)=$S ($P(DG70,U ,26)="Y":" AS",1:$E($ P(DG0,U,10 )_"  ",1,2 ))"RTN","D GPTRI0",55 ,0) ; inco me - $E(Y, 81,86)"RTN ","DGPTRI0 ",56,0) I  $L($P(DG10 1,U,7))>6  S $E(Y,81, 86)="99999 9""RTN","D GPTRI0",57 ,0) E  S X =DG101,Z=7 ,L=6 D FOR MAT0 S $E( Y,81,86)=D GVALUE0"RT N","DGPTRI 0",58,0) ; MST - $E(Y ,87)"RTN", "DGPTRI0", 59,0) S X= $$GETSTAT^ DGMSTAPI(+ DG0) S $E( Y,87)=$S(X <0:"U",1:$ P(X,"^",2) )"RTN","DG PTRI0",60, 0) ;Combat  Vet $E(Y, 88) & $E(Y ,89,94)"RT N","DGPTRI 0",61,0) S  X=$$CVEDT ^DGCV(+DG0 ,$P(DG0,"^ ",2)) S $E (Y,88)=$S( (+X)>0:1,1 :0)"RTN"," DGPTRI0",6 2,0) S X=$ P(X,"^",2) _"       "  S $E(Y,89 ,94)=$E(X, 4,5)_$E(X, 6,7)_$E(X, 2,3)"RTN", "DGPTRI0", 63,0) ;Pro ject 112/S HAD - $E(Y ,95)"RTN", "DGPTRI0", 64,0) S X= $$SHAD^SDC O22(+DG0)  S $E(Y,95) =$S((+X)>0 :1,1:0)"RT N","DGPTRI 0",65,0) ; Emergency  Response I ndicator -  $E(Y,96)" RTN","DGPT RI0",66,0)  S X=$$EMG RES^DGUTL( +DG0) S $E (Y,96)=$S( "^K^"[(U_X _U):X,1:"  ")"RTN","D GPTRI0",67 ,0) ;Count ry Code -  $E(Y,97,99 )"RTN","DG PTRI0",68, 0) S X=$$G ET1^DIQ(77 9.004,$P(D G11,U,10)_ ",",.01),Z =1,L=3 D F ORMAT S $E (Y,97,99)= DGVALUE"RT N","DGPTRI 0",69,0) ; Camp Lejeu ne AF - RS D 2.6.5.6  PTF TRANSM ISSION via  MailMan D G*5.3*914" RTN","DGPT RI0",70,0)  S X=$$GET CL^DGUTL3( +DG0)"RTN" ,"DGPTRI0" ,71,0) S Y =Y_$S(X=1: 1,X=0:0,1: " ")"RTN", "DGPTRI0", 72,0) ;[RE SERVED] -  $E(Y,101,1 12)"RTN"," DGPTRI0",7 3,0) ;[NOT  ALLOCATED ] - $E(Y,1 13,384)"RT N","DGPTRI 0",74,0) K  DGVALUE,D GVALUE0"RT N","DGPTRI 0",75,0) D  SAVE"RTN" ,"DGPTRI0" ,76,0) I T 1 S Y=$E(Y ,53)=" " ; resets SOU RCE OF PAY MENT to sp ace"RTN"," DGPTRI0",7 7,0) ;"RTN ","DGPTRI0 ",78,0)401  ; -- setu p 401 tran sactions ( 402 and 40 3 are no l onger used . All surg eries are  401 segmen ts.)"RTN", "DGPTRI0", 79,0) G 50 1:'$D(^DGP T(J,"S"))  K ^UTILITY ($J,"S") S  I=0"RTN", "DGPTRI0", 80,0)SUR ; "RTN","DGP TRI0",81,0 ) S I=$O(^ DGPT(J,"S" ,I)) G 501 :'I"RTN"," DGPTRI0",8 2,0) S DGS UR=^DGPT(J ,"S",I,0)" RTN","DGPT RI0",83,0)  G SUR:'DG SUR"RTN"," DGPTRI0",8 4,0) G SUR :DGSUR<T1! (DGSUR>T2)  S DGSUD=+ ^(0)\1,^UT ILITY($J," S",DGSUD)= $S($D(^UTI LITY($J,"S ",DGSUD)): ^(DGSUD),1 :0)+1,F=$S (DGSUD<287 1000:0,1:1 ) ;^(0) re ferences g lobal 2 li nes above" RTN","DGPT RI0",85,0)  ;"RTN","D GPTRI0",86 ,0) I ^UTI LITY($J,"S ",DGSUD)>$ S(F:3,1:2)  D  I Y'=1  S DGERR=1  Q"RTN","D GPTRI0",87 ,0) .W !," **There ar e more tha n ",$S(F:" three",1:" two")," su rgeries on  the same  date**""RT N","DGPTRI 0",88,0) . S DIR(0)=" Y",DIR("B" )="YES",DI R("A")="OK  to contin ue?" D ^DI R K DIR"RT N","DGPTRI 0",89,0) ; "RTN","DGP TRI0",90,0 ) ;header,  date of s urgery fol lowed by S PECIALTY -  $E(Y,41,4 2)"RTN","D GPTRI0",91 ,0) S Y=$S (T1:"C",1: "N")_"401" _DGHEAD_$E (DGSUD,4,5 )_$E(DGSUD ,6,7)_$E(D GSUD,2,3)_ $E($P(+DGS UR,".",2)_ "0000",1,4 )_$S($D(^D IC(45.3,+$ P(DGSUR,U, 3),0)):$P( ^(0),U,1), 1:"  ")"RT N","DGPTRI 0",92,0) ; 4 is CATEG ORY OF CHI EF SURGEON  - $E(Y,43 )"RTN","DG PTRI0",93, 0) ;5 is C ATEGORY OF  FIRST ASS ISTANT - $ E(Y,44)"RT N","DGPTRI 0",94,0) ; 6 is ANEST HESIA TECH NIQUE (PRI NCIPAL) -  $E(Y,45)"R TN","DGPTR I0",95,0)  ;7 is SOUR CE OF PAYM ENT - $E(Y ,46)"RTN", "DGPTRI0", 96,0) S L= 1,X=DGSUR  F Z=4:1:7  D ENTER"RT N","DGPTRI 0",97,0) N  EFFDATE,I MPDATE,DGP TDAT D EFF DATE^DGPTI C10(J)"RTN ","DGPTRI0 ",98,0) ;o peration c odes 1 - 2 5 - $E(Y,4 7,246)"RTN ","DGPTRI0 ",99,0) N  DG401CODES ,DGLOOP,DG OCODE,DGST RING,DGPTT MP"RTN","D GPTRI0",10 0,0) D PTF ICD^DGPTFU T(401,J,I, .DG401CODE S) ;get pr ocedure va lues"RTN", "DGPTRI0", 101,0) S D GLOOP=0,DG STRING=""" RTN","DGPT RI0",102,0 ) F  S DGL OOP=$O(DG4 01CODES(DG LOOP)) Q:D GLOOP=""   D"RTN","DG PTRI0",103 ,0) .S DGP TTMP=$$ICD DATA^ICDXC ODE("PROC" ,$P(DG401C ODES(DGLOO P),U,1),EF FDATE,"I")  ;check da ta"RTN","D GPTRI0",10 4,0) .Q:+D GPTTMP'>0   ;don't us e if bad"R TN","DGPTR I0",105,0)  .S DGOCOD E=$P(DG401 CODES(DGLO OP),U,3) ; external v alue"RTN", "DGPTRI0", 106,0) .S  DGSTRING=D GSTRING_DG OCODE_" "  ;append sp ace to pad  to 8 char acters"RTN ","DGPTRI0 ",107,0) S  $E(Y,47,2 46)=DGSTRI NG_$$REPEA T^XLFSTR("  ",200-$L( DGSTRING)) "RTN","DGP TRI0",108, 0) ;-- att  phy [NOT  ACTIVATED  - $E(Y,247 ,256)]"RTN ","DGPTRI0 ",109,0) S  $E(Y,247, 256)="          ""RTN ","DGPTRI0 ",110,0) ; [RESERVED  - $E(Y,256 ,290)]"RTN ","DGPTRI0 ",111,0) ; [NOT ALLOC ATED - $E( Y,291,384) ] "RTN","D GPTRI0",11 2,0) D SAV E G SUR"RT N","DGPTRI 0",113,0)5 01 G 501^D GPTRI2"RTN ","DGPTRI0 ",114,0) Q "RTN","DGP TRI0",115, 0)FORMAT ; format val ue"RTN","D GPTRI0",11 6,0) S DGV ALUE=$J($P (X,U,Z),L) "RTN","DGP TRI0",117, 0) Q"RTN", "DGPTRI0", 118,0)FORM AT0 ;forma t value wi th zeros"R TN","DGPTR I0",119,0)  S DGVALUE 0=$S($P(X, U,Z)]"":$E ("000000", $L($P(X,U, Z))+1,L)_$ P(X,U,Z),1 :$J($P(X,U ,Z),L))"RT N","DGPTRI 0",120,0)  Q"RTN","DG PTRI0",121 ,0) ;"RTN" ,"DGPTRI0" ,122,0)ENT ER S Y=Y_$ J($P(X,U,Z ),L)"RTN", "DGPTRI0", 123,0) Q"R TN","DGPTR I0",124,0) ENTER0 S Y =Y_$S($P(X ,U,Z)]"":$ E("000000" ,$L($P(X,U ,Z))+1,L)_ $P(X,U,Z), 1:$J($P(X, U,Z),L))"R TN","DGPTR I0",125,0)  Q"RTN","D GPTRI0",12 6,0)SAVE ; "RTN","DGP TRI0",127, 0) D SAVE^ DGPTRI2"RT N","DGPTRI 0",128,0)Q  Q"RTN","D GPTRI0",12 9,0)DGNAM  S X=DGNAM  I X?.E.P F  I=1:1:$L( X) S Z=$E( X,I) Q:Z=" ,"  S:Z?.P &(Z]"") X= $E(X,1,I-1 )_$E(X,I+1 ,$L(X)),I= I-1 Q:X'?. E.P"RTN"," DGPTRI0",1 30,0) I X? .E.L D UP^ DGHELP"RTN ","DGPTRI0 ",131,0) S  DGNAM=X"R TN","DGPTR I0",132,0)  Q"RTN","D GPTRI0",13 3,0) ;"RTN ","DGPTRI0 ",134,0)PT FNMFT(DG10 ) ;this fu nction wil l format t he name of  the patie nt for"RTN ","DGPTRI0 ",135,0) ;  transmiss ion of the  101 recor d to Austi n. In addi tion, this "RTN","DGP TRI0",136, 0) ; funct ion will b e used by  OPC so tha t the form at will be  consisten t"RTN","DG PTRI0",137 ,0) ; for  OPC and PT F."RTN","D GPTRI0",13 8,0) ;  IN PUT :   DG 10 - .01 f ield from  the patien t record." RTN","DGPT RI0",139,0 ) ;  OUTPU T:   name  in the for mat proper  format."R TN","DGPTR I0",140,0)  ;         A = <12 -  characters  of last n ame padded  with blan ks>"RTN"," DGPTRI0",1 41,0) ;         B = < 1  - first  initial o f fist nam e>"RTN","D GPTRI0",14 2,0) ;         C = <1   - first  initial of  middle na me>"RTN"," DGPTRI0",1 43,0) ;       returns  :ABC <14  - characte rs>"RTN"," DGPTRI0",1 44,0) N X, I"RTN","DG PTRI0",145 ,0) S DGNA M=DG10 D D GNAM"RTN", "DGPTRI0", 146,0) Q $ E($P(DGNAM ,",",1)_"             ",1,12)_$J ($E($P(DGN AM,",",2), 1),1)_$J($ E($P($P(DG NAM,",",2) ," ",2),1) ,1)"RTN"," DGPTRI1")0 ^63^B46716 592"RTN"," DGPTRI1",1 ,0)DGPTRI1  ;ALB/MTC, HIOFO/FT -  PTF VERIF ICATION ;0 7/21/2015   7:14 AM"R TN","DGPTR I1",2,0) ; ;5.3;Regis tration;** 850,884,91 4**;Aug 13 , 1993;Bui ld 104"RTN ","DGPTRI1 ",3,0) ;;U pdated DGP TR1 for IC D-10 Trans mission;;2 /28/2012 -  850"RTN", "DGPTRI1", 4,0) ;"RTN ","DGPTRI1 ",5,0) ;no  external  references "RTN","DGP TRI1",6,0)  ;"RTN","D GPTRI1",7, 0)START ;  Called fro m other DG PTRI* rout ines to do  data vali dation and  display e rrors"RTN" ,"DGPTRI1" ,8,0) ;How  this vali dation wor ks:"RTN"," DGPTRI1",9 ,0) ; Y is  the segme nt (e.g.,  101, 401)  character  string"RTN ","DGPTRI1 ",10,0) ;  Figure out  which seg ment it is . Characte rs 2 & 3 w ill be eit her 10, 40 , 50, 53,  60 or 70.  (i.e., T)" RTN","DGPT RI1",11,0)  ; Set ERR  to a text  line (e.g ., T10) wh ich has th e field or der and na me in the  segment. ( e.g., 1:NA ME)"RTN"," DGPTRI1",1 2,0) ; The  patient n ame is the  first fie ld to be c hecked."RT N","DGPTRI 1",13,0) ;  Set W to  a text lin e (e.g., 1 0) which h as four nu mbers deli mited by s emi-colons  for each  "^" piece. "RTN","DGP TRI1",14,0 ) ; Each " ^" piece c orresponds  to a fiel d in the s egment str ing (Y). T here can b e more tha n one "^"  piece "RTN ","DGPTRI1 ",15,0) ;  for each f ield."RTN" ,"DGPTRI1" ,16,0) ; S et F to th e first ch aracter of  the segme nt to begi n checking ."RTN","DG PTRI1",17, 0) ; The c haracters  prior to 3 1 are "Con trol Data"  values su ch as SSN  and Admiss ion Date/T ime."RTN", "DGPTRI1", 18,0) ; DO  L which l oops throu gh the var ious text  lines such  as T10 an d 10 and v alidate th e characte rs with"RT N","DGPTRI 1",19,0) ;  pattern m atch code  defined in  the LOGIC  subroutin e."RTN","D GPTRI1",20 ,0) ; If t he pattern  match fai ls, the ER R subrouti ne is call ed and an  error mess age is wri tten to th e screen." RTN","DGPT RI1",21,0)  ; Finally , do any D nn subrout ines which  have addi tional che cks."RTN", "DGPTRI1", 22,0) ;"RT N","DGPTRI 1",23,0) Q :$E(Y,2,4) =702  ;com e back to? "RTN","DGP TRI1",24,0 ) S T=$E(Y ,2,3) ;det ermine seg ment"RTN", "DGPTRI1", 25,0) S ER R=$P($T(@( "T"_T)),"; ;",2,999), W=$P($T(@( T)),";;",2 ,999),F=31  D L"RTN", "DGPTRI1", 26,0) I T= 70 S ERR=$ P($T(T701) ,";;",2,99 9),W=$P($T (701),";;" ,2,999),F= 73 D L"RTN ","DGPTRI1 ",27,0) D  @("D"_T) Q "RTN","DGP TRI1",28,0 ) K DGFILL "RTN","DGP TRI1",29,0 ) Q"RTN"," DGPTRI1",3 0,0) ;"RTN ","DGPTRI1 ",31,0)L ; "RTN","DGP TRI1",32,0 ) ;$P(DG11 ,U,10) is  FILE 2, Fi eld .1173  which is C OUNTRY [10 P:779.004] "RTN","DGP TRI1",33,0 ) N DGFOR  S DGFOR=$S ($$FORIEN^ DGADDUTL($ P(DG11,U,1 0))<1:0,1: 1) ;set fo reign coun try flag = 1, else, s et as dome stic"RTN", "DGPTRI1", 34,0) F H= 1:1 S DGO= $P(W,U,H)  Q:'DGO  D   ;find out  how many  values in  the segmen t you want  to valida te"RTN","D GPTRI1",35 ,0) . F Z= 1:1:$P(DGO ,";",3) D   ;Find out  how many  characters  are in th e value yo u want to  validate"R TN","DGPTR I1",36,0)  .. S DGL=D GLOGIC(+DG O) ;get th e pattern  match need ed to chec k the char acter(s)"R TN","DGPTR I1",37,0)  .. S X=$E( Y,F) ;get  the charac ter to val idate"RTN" ,"DGPTRI1" ,38,0) ..  D @("ERR:" _DGL) ;if  the charac ter fails  the patter n match, c all ERR to  display a  message"R TN","DGPTR I1",39,0)  .. S F=F+1  ;incremen t F to get  the next  character  in the seg ment"RTN", "DGPTRI1", 40,0) Q"RT N","DGPTRI 1",41,0) ; "RTN","DGP TRI1",42,0 ) ;The Tnn  lines hav e the SEQU ENCE #:FIE LD NAME fo r all of t he fields  in that se gment."RTN ","DGPTRI1 ",43,0) ;e .g., '1:NA ME' is the  patient N AME and it  is the fi rst field  in the 101  segment.  SOURCE OF  ADM(ISSION ) is the s econd and  so on"RTN" ,"DGPTRI1" ,44,0) ; 1 01 segment "RTN","DGP TRI1",45,0 )T10 ;;1:N AME^2:SOUR CE OF ADM^ 3:TRANS FA C.^4:SOURC E OF PAY^5 :POW^6:MAR ITAL ST^7: SEX^8:DOB^ 9:POS^10:V IETNAM^11: ION RADIAT ION^12:RES IDENCE^13: MEANS TEST ^14:INCOME ^15:MST^16 :COMBAT VE T^17:CV EN D DT^18:PR OJ 112/SHA D^19:ERI^2 0:COUNTRY^ 21:CAMP LE JEUNE"RTN" ,"DGPTRI1" ,46,0) ; 7 01 segment  (part 1)" RTN","DGPT RI1",47,0) T70 ;;1:DT  OF DISP.^ 2:DISCH BD  SEC^3:TYP E OF DIS^4 :OUT TREAT ^5:VA AUS^ 6:PL OF DI S^7:REC FA C^8:ASIH D AYS^9:RACE ^10:C&P ST AT^11:PDXL S^12:ONLY  DX^13:PHY  MPCR"RTN", "DGPTRI1", 48,0) ; T7 01 segment  (part 2)" RTN","DGPT RI1",49,0) T701 ;;1:P HY SPEC^2: %SC^3:LEGI ON^4:SUICI DE^5:DRUG^ 6:AXIS-IV^ 7:AXIS-V^8 :SC^9:EXP^ 10:MST^11: HNC^12:ETH NICITY^13: RACE^14:CO MBAT VET^1 5:PROJ 112 /SHAD^16:A SIH^17:CAM P LEJEUNE" RTN","DGPT RI1",50,0)  ; 501 seg ment"RTN", "DGPTRI1", 51,0)T50 ; ;1:DT OF M VMT^2:LOSI NG BD SEC  MPCR^3:LOS ING BD SEC ^4:LEAVE D AYS^5:PASS  DAYS^6:SC I^7:DIAG^8 :DOCTOR'S  SSN^9:PHY  MPCR^10:PH Y SPEC^11: DISCHARGE  STAT^^^^^1 6:LEGION^1 7:SUICIDE^ 18:DRUG^19 :AXIS-IV^2 0:AXIS-V^2 1:SC^22:EX P^23:MST^2 4:HNC"RTN" ,"DGPTRI1" ,52,0) ; 5 35 segment "RTN","DGP TRI1",53,0 )T53 ;;1:D ATE OF PHY SICAL MOVE MENT^2:LOS ING PHYSIC AL MPCR^3: LOSING PHY SICAL SPEC IALTY^4:TR  SPECIALTY  MPCR^5:TR  SPECIALTY ^6:LEAVE D AYS^7:PASS  DAYS"RTN" ,"DGPTRI1" ,54,0) ; 4 01 segment "RTN","DGP TRI1",55,0 )T40 ;;1:D ATE OF SUR GERY^2:SUR G SPEC.^3: CAT CHIEF  SURGEON^4: CAT FIRST  ASS^5:ANES T. TECH.^6 :SOURCE OF  PAY^7:OP  CODE"RTN", "DGPTRI1", 56,0) ; 60 1 segment" RTN","DGPT RI1",57,0) T60 ;;1:DA TE OF PROC EDURE^2:LO SING BD SE C^3:DIALYS IS TYPE^4: NUMBER OF  TREATMENTS ^5:PROCEDU RE CODE"RT N","DGPTRI 1",58,0) ; "RTN","DGP TRI1",59,0 ) ;LOGIC i s a bunch  of single  or compoun d pattern  matches de limited by  an "^". A  pattern m atch is us ed in the  DGL variab le"RTN","D GPTRI1",60 ,0) ;in th e L entry  point abov e as a pos t-conditio nal value  on the ERR  subroutin e. If the  pattern ma tch fails,  then ERR  is"RTN","D GPTRI1",61 ,0) ;calle d to write  an error  message on  the scree n to the u ser. "RTN" ,"DGPTRI1" ,62,0)LOGI C ;;X'?.N^ X'?.A&(X'= " ")^X'="  "^X'?.N&(X '=" ")^X'? .A&(X'=" " )^0^X'?.N& (X'="X")^X '=" "&(X'= "P")^X="E" ^X="Y"^X="  "^X'="A"& (X'=" ")^( X'?.A)&(X' ?.N)&(X'="  ")^(X'?.A N)&('$P(DG 0,U,4))^(( T1)&(X'="  "))!(('T1) &(X'?.AN)& ('$P(DG0,U ,4)))"RTN" ,"DGPTRI1" ,63,0) ;;( X'?.AN)^'$ D(DGFOR)&( X'?.N)^'$D (DGFOR)&X' ?.N&(X'="X ")^X'?AN&X '=""^"YNUW  "']X"RTN" ,"DGPTRI1" ,64,0) ;;E ND"RTN","D GPTRI1",65 ,0) ;"RTN" ,"DGPTRI1" ,66,0) ;Th e followin g nn lines  are value s used by  the L entr y point to  validate  the data." RTN","DGPT RI1",67,0)  ;Each "^"  piece con tains for  numbers de limited by  semi-colo ns."RTN"," DGPTRI1",6 8,0) ;The  first numb er identif ies the "^ " piece in  the LOGIC  string to  get the p attern mat ch to use. "RTN","DGP TRI1",69,0 ) ;The sec ond number  identifie s the edit  field. [n eed to ela borate on  this more] ."RTN","DG PTRI1",70, 0) ;The th ird number  identifie s the numb er of char acters in  the segmen t to check ."RTN","DG PTRI1",71, 0) ;The fo urth numbe r identifi es the a p iece in th e Tnn stri ng (above)  to get th e field na me to disp lay."RTN", "DGPTRI1", 72,0) ;i.e , in "10",  the first  "^" piece  is 6;;12; 1"RTN","DG PTRI1",73, 0) ;Use th e pattern  match in t he sixth " ^" of the  LOGIC text  line."RTN ","DGPTRI1 ",74,0) ;T he edit fi eld is nul l because  the patien t name can not be edi ted in the  PTF softw are."RTN", "DGPTRI1", 75,0) ;12  represents  the first  12 charac ters of th e patient' s last nam e that wil l be check ed."RTN"," DGPTRI1",7 6,0) ;1 re presents t he first " ^" piece o f the T10  text line  (i.e., 1:N AME). NAME  is the fi eld name t hat will b e displaye d"RTN","DG PTRI1",77, 0) ;in the  error mes sage to th e user.  " RTN","DGPT RI1",78,0)  ; edit ch eck# ; edi t field ;  # x check  preformed  ; display  error name  #"RTN","D GPTRI1",79 ,0) ; 101  segment"RT N","DGPTRI 1",80,0)10  ;;6;;12;1 ^2;1;1;1^5 ;1;1;1^1;2 ;1;2^2;2;1 ;2^4;3;3;3 ^6;;3;3^4; 4;1;4^6;5; 1;5^2;6;1; 6^2;7;1;7^ 1;8;8;8^6; ;1;9^11;9; 1;9^4;10;1 ;10^4;10;1 ;11^17;11; 5;12^18;11 ;5;12^2;12 ;1;13^6;;1 ;13^1;;6;1 4^2;;1;15^ 1;;1;16^4; ;6;17^1;;1 ;18^5;;1;1 9^5;;3;20^ 4;;1;21"RT N","DGPTRI 1",81,0) ;  701 segme nt (part 1 )"RTN","DG PTRI1",82, 0)70 ;;1;1 ;10;1^13;2 ;2;2^1;3;1 ;3^4;4;1;4 ^4;5;1;5^6 ;;1;6^4;7; 3;7^6;;3;7 ^4;8;3;8^6 ;9;1;9^1;1 0;1;10^6;1 1;1;11^6;1 1;2;11^6;; 3;11^6;11; 1;11^20;;1 ;11^6;;1;1 2^15;;6;13 "RTN","DGP TRI1",83,0 ) ; 701 se gment (par t 2)"RTN", "DGPTRI1", 84,0)701 ; ;15;;2;1^1 ;;3;2^6;;1 ;3^6;;1;4^ 6;;1;5^6;; 3;5^6;;1;6 ^6;;4;7^4; ;1;8^5;;3; 9^5;;1;10^ 5;;1;11^13 ;12;2;12^1 3;13;12;13 ^5;;1;14^5 ;;1;15^6;; 3;16^5;;1; 17"RTN","D GPTRI1",85 ,0) ; 501  segment"RT N","DGPTRI 1",86,0)50  ;;1;1;10; 1^1;;6;2^1 6;3;2;3^1; 4;3;4^1;5; 3;5^6;;1;6 ^11;7;3;7^ 6;;197;7^6 ;;9;8^14;; 6;9^14;;2; 10^6;;1;11 ^6;;1;16^6 ;;1;17^6;; 1;18^6;;3; 18^6;;1;19 ^6;;4;20^6 ;;1;21^6;; 3;22^5;;1; 23^6;;1;24 "RTN","DGP TRI1",87,0 ) ; 535 se gment"RTN" ,"DGPTRI1" ,88,0)53 ; ;1;;10;1^1 ;;6;2^13;; 2;3^1;;6;4 ^13;;2;5^1 ;;3;6^1;;3 ;7"RTN","D GPTRI1",89 ,0) ; 401  segment"RT N","DGPTRI 1",90,0)40  ;;1;1;10; 1^1;2;2;2^ 11;3;1;3^4 ;4;1;4^6;5 ;1;5^4;6;1 ;6^11;7;2; 7^6;;200;7 "RTN","DGP TRI1",91,0 ) ; 601 se gment"RTN" ,"DGPTRI1" ,92,0)60 ; ;1;1;10;1^ 13;2;2;2^4 ;3;1;3^4;4 ;3;4^11;5; 2;5^6;;198 ;5"RTN","D GPTRI1",93 ,0) ;"RTN" ,"DGPTRI1" ,94,0)ERR  S DGERR=1  ;if DGERR> 0, the seg ment is no t put in t he mail me ssage or ^ TMP("AEDIT ")"RTN","D GPTRI1",95 ,0) W !,T, $S(T["H":"  ",1:$E(Y, 4)),"  ""R TN","DGPTR I1",96,0)  W:"45"[$E( T,1) $E(Y, 31,32),"-" ,$E(Y,33,3 4),"-",$E( Y,35,36)," @",$E(Y,37 ,40) ;writ e date of  procedure/ dx code"RT N","DGPTRI 1",97,0) W  ?25,$P($P (ERR,U,$P( DGO,";",4) ),":",2),? 40,"COL.", F,"  VALUE : ",$S($E( Y,F)=" ":" BLANK",1:$ E(Y,F)) ;w rite field  name,colu mn positio n and valu e"RTN","DG PTRI1",98, 0) S I=$S( '$D(I):1,I >0:I,1:1), ^(I)=$S($D (^UTILITY( "DG",$J,T_ $S(T["H":" ",1:$E(Y,4 )),I)):^(I ),1:U) I $ P(DGO,";", 2),^(I)'[( U_$P(DGO," ;",2)_U) S  ^(I)=^(I) _$P(DGO,"; ",2)_U"RTN ","DGPTRI1 ",99,0) Q" RTN","DGPT RI1",100,0 ) ;"RTN"," DGPTRI1",1 01,0)D10 ; "RTN","DGP TRI1",102, 0) ;column  66 is PER IOD OF SER VICE, "Z"  indicates  Merchant M arines, "1 0" indicat es VIETNAM  (Agent Or ange expos ure)"RTN", "DGPTRI1", 103,0) I $ E(Y,66)="Z " S (F,H)= 68,W="11;1 0;1;10" D  L"RTN","DG PTRI1",104 ,0) Q"RTN" ,"DGPTRI1" ,105,0) ;" RTN","DGPT RI1",106,0 )D40 Q"RTN ","DGPTRI1 ",107,0)DP 40 Q"RTN", "DGPTRI1", 108,0) ;"R TN","DGPTR I1",109,0) D70 ;colum n 43 is TY PE OF DISP OSITION, 4 4 is OUTPA TIENT CARE  STATUS"RT N","DGPTRI 1",110,0)  ;In "W", 4  indicates  OUTPATIEN T TREATMEN T, 5 indic ates VA AU SPICES and  6 indicat es PLACE O F DISPOSIT ION"RTN"," DGPTRI1",1 11,0) Q:$E (Y,2,4)=70 1"RTN","DG PTRI1",112 ,0) I "467 "'[$E(Y,43 ) S F=44,W ="4;4;1;4^ 1;5;1;5^11 ;6;1;6" D  L"RTN","DG PTRI1",113 ,0) Q"RTN" ,"DGPTRI1" ,114,0)D50  ;$P(DG0,U ,5) is SUF FIX (File  45, field  5). column  55 is SPI NAL CORD I NJURY "RTN ","DGPTRI1 ",115,0) I  "A0"[$P(D G0,U,5)!(" A4"[$P(DG0 ,U,5))!('$ D(^DGPT(J, 70))) S W= "11;6;1;6" ,F=55 D L  ;if $P(DG0 ,U,5) is n ull, this  will execu te"RTN","D GPTRI1",11 6,0) I $D( ^DGPT(J,70 )),$S(T1:1 ,1:+^(70)> 2871000) S  W="11;6;1 ;6",F=55 D  L"RTN","D GPTRI1",11 7,0) ;I $E (Y,4)=1 S  W="9;7;1;7 ",F=56 D L "RTN","DGP TRI1",118, 0) ; colum n 273 is B ED STATUS  (DISCHARGE  MOVEMNT O NLY)"RTN", "DGPTRI1", 119,0) I I =1,'T1 S W ="1;11;1;1 1",F=273 D  L"RTN","D GPTRI1",12 0,0) Q"RTN ","DGPTRI1 ",121,0)D5 3 Q"RTN"," DGPTRI1",1 22,0) ;col umn 43 is  DIALYSIS T YPE, colum n 44 is NU MBER OF TR EATMENTS a nd the 4 i n "W" is a lso NUMBER  OF TREATM ENTS"RTN", "DGPTRI1", 123,0)D60  I $E(Y,43)  S F=44,W= "1;4;3;4"  D L"RTN"," DGPTRI1",1 24,0) Q"RT N","DGPTRI 1",125,0)  ;called fr om DGPTRI0 "RTN","DGP TRI1",126, 0)HEAD S E RR="1:SSN^ 2:ADMISSIO N DATE^3:F ACILITY #" ,W="8;1;1; 1^1;1;9;1^ 1;2;10;2^1 ;3;3;3^6;; 3;3",F=5,T ="HEADER"  D LOG"RTN" ,"DGPTRI1" ,127,0) D  L"RTN","DG PTRI1",128 ,0) Q"RTN" ,"DGPTRI1" ,129,0)LOG  ;place DG LOGIC in a rray in or der to add  more logi c tests ;D G*5.3*664" RTN","DGPT RI1",130,0 ) K DGLOGI C ;S DGLOG IC=$P($T(L OGIC),";;" ,2)"RTN"," DGPTRI1",1 31,0) N LO GX,LOGI,LO GCNT,II,XX "RTN","DGP TRI1",132, 0) S LOGI= 0,LOGCNT=1 "RTN","DGP TRI1",133, 0) F LOGI= 0:1 S LOGX =$P($T(LOG IC+LOGI)," ;;",2) Q:L OGX="END"   F II=1:1  S XX=$P(LO GX,U,II) Q :XX=""  S  DGLOGIC(LO GCNT)=XX,L OGCNT=LOGC NT+1"RTN", "DGPTRI1", 134,0) Q"R TN","DGPTR I1",135,0) CEN ;calle d from 701 ^DGPTRI4"R TN","DGPTR I1",136,0)  S T=70,ER R=$P($T(T7 0),";;",2) ,W=$P($T(7 0),";;",2, 999),W="6; 9;1;9"_$P( W,"6;9;1;9 ",2,999),F =56 D L ;5 6 is RACE  column"RTN ","DGPTRI1 ",137,0) S  ERR=$P($T (T701),";; ",2),W=$P( $T(701),"; ;",2,999), F=73 D L"R TN","DGPTR I1",138,0)  Q"RTN","D GPTRI1",13 9,0) ;"RTN ","DGPTRI1 ",140,0)DI AGPTRN(DGD IAG) ; --  icd-10 dia gnosis pat tern match "RTN","DGP TRI1",141, 0) ;    1   2  3  4   5  6  7  8 "RTN","DGP TRI1",142, 0) ;    -   -  -  -   -  -  -  - "RTN","DGP TRI1",143, 0) ;    U   N  U  .   U  U  N  U "RTN","DGP TRI1",144, 0) ;    X      N      N  N  x  N "RTN","DGP TRI1",145, 0) ;                  x  x  n  n "RTN","DGP TRI1",146, 0) ;                  n  n     " RTN","DGPT RI1",147,0 ) N OKAY S  OKAY=0"RT N","DGPTRI 1",148,0)  I DGDIAG?1 U1N1UN1"." .4AN S OKA Y=1"RTN"," DGPTRI1",1 49,0) Q OK AY"RTN","D GPTRI1",15 0,0)TEST ; "RTN","DGP TRI1",151, 0) W !,"F1 4. ",$$DIA GPTRN("F14 .")"RTN"," DGPTRI1",1 52,0) W !, "G1G.1234  ",$$DIAGPT RN("G1G.12 34")"RTN", "DGPTRI1", 153,0) W ! ,"330. ",$ $DIAGPTRN( "330")"RTN ","DGPTRI1 ",154,0) W  !,"R54.3X xY ",$$DIA GPTRN("R54 .3XxY")"RT N","DGPTRI 1",155,0)  W !,"R543X xY ",$$PRO CPTRN("R54 3XxY")"RTN ","DGPTRI1 ",156,0) W  !,"10.44  ",$$PROCPT RN("10.44" )"RTN","DG PTRI1",157 ,0) W !,"3 S82B1 ",$$ PROCPTRN(" 3S82B1")"R TN","DGPTR I1",158,0)  W !,"G232 44X ",$$PR OCPTRN("G2 3244X")"RT N","DGPTRI 1",159,0)  Q"RTN","DG PTRI1",160 ,0) ;"RTN" ,"DGPTRI1" ,161,0)PRO CPTRN(DGPR OC) ;ICD-1 0 Procedur e Code Pat tern Match "RTN","DGP TRI1",162, 0) ; "RTN" ,"DGPTRI1" ,163,0) ;     1  2  3   4  5  6   7"RTN","D GPTRI1",16 4,0) ;     -  -  -  -   -  -  -" RTN","DGPT RI1",165,0 ) ;    U   U  U  U  U   U  U"RTN ","DGPTRI1 ",166,0) ;     N  N   N  N  N  N   N"RTN"," DGPTRI1",1 67,0) ;        Z      Z  Z  Z  Z "RTN","DGP TRI1",168, 0) ; "RTN" ,"DGPTRI1" ,169,0) N  OKAY S OKA Y=0"RTN"," DGPTRI1",1 70,0) I DG PROC?7UN S  OKAY=1"RT N","DGPTRI 1",171,0)  Q OKAY"RTN ","DGPTRI4 ")0^27^B71 363613"RTN ","DGPTRI4 ",1,0)DGPT RI4 ;ALB/J DS/MJK/MTC /ADL/TJ/BO K,ISF/GJW, HIOFO/FT -  PTF TRANS MISSION ;5 /11/15 12: 24pm"RTN", "DGPTRI4", 2,0) ;;5.3 ;Registrat ion;**850, 884,914**; Aug 13, 19 93;Build 1 04"RTN","D GPTRI4",3, 0) ;"RTN", "DGPTRI4", 4,0) ; ^XM B(3.9) - # 10066"RTN" ,"DGPTRI4" ,5,0) ; XL FSTR APIs  - 10104"RT N","DGPTRI 4",6,0) ;" RTN","DGPT RI4",7,0)7 01 ; -- se tup 701 tr ansaction" RTN","DGPT RI4",8,0)  S Y=$$N701 (J,T1)"RTN ","DGPTRI4 ",9,0) N K "RTN","DGP TRI4",10,0 ) ;For Cen sus record s, send sp aces for D ISCHARGE S PECIALTY C ODE (41-42 ), TYPE OF  DISPOSITI ON (43), O UTPATIENT  CARE STATU S (44),"RT N","DGPTRI 4",11,0) ; UNDER VA A USPICES (4 5), PLACE  OF DISPOSI TION (46),  RECEIVING  FACILITY  NUMBER (47 -49), RECE IVING FACI LITY"RTN", "DGPTRI4", 12,0) ;SUF FIX (50-52 ), DXLS ON LY (66), P HYSICAL LO CATION CDR  CODE (67- 72) and PH YSICAL LOC ATION CODE  (73-74)"R TN","DGPTR I4",13,0)  I T1 F K=4 1:1:52,66: 1:74 S $E( Y,K)=" ""R TN","DGPTR I4",14,0)  I T1 D CEN ^DGPTRI1 D :'DGERR CS AVE ;S:'DG ERR ^XMB(3 .9,DGXMZ,2 ,DGCNT,0)= Y,DGCNT=DG CNT+1 Q"RT N","DGPTRI 4",15,0) I  'T1 D SAV E"RTN","DG PTRI4",16, 0) ;"RTN", "DGPTRI4", 17,0)702 ; create 702  only if t here are s econdary D Xs"RTN","D GPTRI4",18 ,0) Q:$G(D GRTY)=2  ; don't send  702 for c ensus reco rd"RTN","D GPTRI4",19 ,0) Q:$$DX LSONLY^DGP TRNU1(J)   ;DXLS only  (no secon dary diagn oses)"RTN" ,"DGPTRI4" ,20,0) S Y =$$N702(J) "RTN","DGP TRI4",21,0 ) D SAVE^D GPTRI2"RTN ","DGPTRI4 ",22,0) Q" RTN","DGPT RI4",23,0)  ;"RTN","D GPTRI4",24 ,0)POA(Y)  ;-- Add PO A to end o f 101 segm ent with P OA ;FT 3/2 3/15 - MAY  NOT BE NE EDED"RTN", "DGPTRI4", 25,0) N DG POA,L,K S  DGPOA=$G(^ DGPT(J,82) )"RTN","DG PTRI4",26, 0) S L=$P( DG70,U,10) _U_$P(DG70 ,U,16,24)_ U_DG71"RTN ","DGPTRI4 ",27,0) F  K=1:1:13 S  Y=Y_$S($P (L,U,K)'=" ":$$POAVAL ($P(DGPOA, U,K)),1:"  ") ;6/18/2 012 send w hat is sto red per ca ll with Do rothea Gar rett."RTN" ,"DGPTRI4" ,28,0) Q"R TN","DGPTR I4",29,0)  ;"RTN","DG PTRI4",30, 0)POAVAL(P OA) ; -- C onvert POA  indicator  to a 1 or  0 for use  in calcul ating DRG" RTN","DGPT RI4",31,0)  ; -- note :  Transmi ssion of s pace " " i f no corre sponding D IAGNOSIS"R TN","DGPTR I4",32,0)  ; -- see P OA^DGPTFD,  same logi c, differe nt return  values."RT N","DGPTRI 4",33,0) S  POA=$G(PO A)"RTN","D GPTRI4",34 ,0) ;"RTN" ,"DGPTRI4" ,35,0) ; - - On 8/9/2 012 the AD T SME Dete rmined tha t null POA  should be  defaulted  to Yes"RT N","DGPTRI 4",36,0) ;     Due to  the fact  that the C OTS PTF so ftware was  not uploa ding POA i nformation ."RTN","DG PTRI4",37, 0) Q $S(PO A="Y":"Y", POA="N":"N ",POA="":" Y",POA="U" :"U",POA=" W":"W",1:" Y")"RTN"," DGPTRI4",3 8,0) ;"RTN ","DGPTRI4 ",39,0)ENT ER S Y=Y_$ J($P(X,U,Z ),L)"RTN", "DGPTRI4", 40,0) Q"RT N","DGPTRI 4",41,0) ; "RTN","DGP TRI4",42,0 )ENTER0 S  Y=Y_$S($P( X,U,Z)]"": $E("00000" ,$L($P(X,U ,Z))+1,L)_ $P(X,U,Z), 1:$J($P(X, U,Z),L))"R TN","DGPTR I4",43,0)  Q"RTN","DG PTRI4",44, 0) ;"RTN", "DGPTRI4", 45,0)SAVE  ;validate  data and s ave to Mai lMan messa ge & ^TMP( "AEDIT",$J )"RTN","DG PTRI4",46, 0) D SAVE^ DGPTRI2"RT N","DGPTRI 4",47,0)Q  Q"RTN","DG PTRI4",48, 0) ;"RTN", "DGPTRI4", 49,0)CSAVE  ;sets Mai lMan messa ge, not ^T MP("AEDIT" ,$J)"RTN", "DGPTRI4", 50,0) N DG Y1,DGY2"RT N","DGPTRI 4",51,0) D  FILL^DGPT RI2 ;fill  out Y to 3 84 charact ers"RTN"," DGPTRI4",5 2,0) I $E( Y,2,4)=701  S DGY1=$E (Y,1,240), DGY2=$E(Y, 241,384) D "RTN","DGP TRI4",53,0 ) .S ^XMB( 3.9,DGXMZ, 2,DGCNT,0) =DGY1,DGCN T=DGCNT+1" RTN","DGPT RI4",54,0)  .S ^XMB(3 .9,DGXMZ,2 ,DGCNT,0)= DGY2,DGCNT =DGCNT+1"R TN","DGPTR I4",55,0)  Q"RTN","DG PTRI4",56, 0)CDR S Y= Y_$E($P(Z, ".")_"0000 ",1,4)_$E( $P(Z,".",2 )_"00",1,2 )"RTN","DG PTRI4",57, 0) Q"RTN", "DGPTRI4", 58,0)RTEN( X) ; This  function w ill round  X to the n earest mul tiple of t en."RTN"," DGPTRI4",5 9,0) ; 0-4  ->DOWN; 5 -9->UP"RTN ","DGPTRI4 ",60,0) Q  (X\10)*10+ $S(X#10>4: 10,1:0)"RT N","DGPTRI 4",61,0) ; "RTN","DGP TRI4",62,0 )ETHNIC(DG PTJ) ;Ethn icity (use  first act ive value) "RTN","DGP TRI4",63,0 ) ;Input -  PTF ien"R TN","DGPTR I4",64,0)  ;Output -  character  string con taining on e ethnicit y value an d collecti on method" RTN","DGPT RI4",65,0)  N DGARRAY ,DGNODE,DG NUM,DGETHN IC,DGLOOP, DGX,DGY"RT N","DGPTRI 4",66,0) M  DGARRAY=^ DPT(+^DGPT (DGPTJ,0), .06) ;get  ETHNIC mul tiple from  File 2"RT N","DGPTRI 4",67,0) S  (DGETHNIC ,DGY)="",D GLOOP=0,DG NUM=1"RTN" ,"DGPTRI4" ,68,0) F   S DGLOOP=+ $O(DGARRAY (DGLOOP))  Q:'DGLOOP   D  Q:DGNU M>1"RTN"," DGPTRI4",6 9,0) .S DG NODE=$G(DG ARRAY(DGLO OP,0))"RTN ","DGPTRI4 ",70,0) .Q :('DGNODE) !('$D(^DIC (10.2,+DGN ODE,0)))   ;10.2=ETHN ICITY file "RTN","DGP TRI4",71,0 ) .Q:$$INA CTIVE^DGUT L4(+DGNODE ,2)  ;(VAL UE,TYPE) w here +DGNO DE=ethnici ty value a nd 2=ETHNI CITY"RTN", "DGPTRI4", 72,0) .S D GX=$$PTR2C ODE^DGUTL4 (+DGNODE,2 ,4) ;(VALU E,TYPE,COD E) where + DGNODE=eth nicity ien , 2=ETHNIC ITY and 4= PTF"RTN"," DGPTRI4",7 3,0) .S DG ETHNIC=$S( DGX="":" " ,1:DGX)"RT N","DGPTRI 4",74,0) . S DGX=$$PT R2CODE^DGU TL4(+$P(DG NODE,"^",2 ),3,4) ;(V ALUE,TYPE, CODE) wher e $P(DGNOD E,U,2)=eth nicity ien , 3=collec tion metho d ien and  4=PTF"RTN" ,"DGPTRI4" ,75,0) .S  DGETHNIC=D GETHNIC_$S (DGX="":"  ",1:DGX)"R TN","DGPTR I4",76,0)  .S DGNUM=D GNUM+1"RTN ","DGPTRI4 ",77,0) S  DGY=DGY_$S (DGETHNIC= "":"  ",1: DGETHNIC)" RTN","DGPT RI4",78,0)  Q DGY"RTN ","DGPTRI4 ",79,0) ;" RTN","DGPT RI4",80,0) RACE(DGPTJ ) ;-- Race  (use firs t 6 active  values)"R TN","DGPTR I4",81,0)  ;Input - P TF ien"RTN ","DGPTRI4 ",82,0) ;O utput - ch aracter st ring conta ining up t o six race  and colle ction meth ods"RTN"," DGPTRI4",8 3,0) N DGA RRAY,DGNOD E,DGNUM,DG RACE,DGI,D GK,DGX,DGY "RTN","DGP TRI4",84,0 ) M DGARRA Y=^DPT(+^D GPT(DGPTJ, 0),.02) ;g et RACE mu ltiple fro m FILE 2"R TN","DGPTR I4",85,0)  S (DGRACE, DGY)="",DG I=0,DGNUM= 1"RTN","DG PTRI4",86, 0) F  S DG I=+$O(DGAR RAY(DGI))  Q:'DGI  D   Q:DGNUM>6 "RTN","DGP TRI4",87,0 ) .S DGNOD E=$G(DGARR AY(DGI,0)) "RTN","DGP TRI4",88,0 ) .Q:('DGN ODE)!('$D( ^DIC(10,+D GNODE,0)))   ;10=RACE  file"RTN" ,"DGPTRI4" ,89,0) .Q: $$INACTIVE ^DGUTL4(+D GNODE)  ;( VALUE,TYPE ) where +D GNODE=race  value and  1=RACE (d efault is  1)"RTN","D GPTRI4",90 ,0) .S DGX =$$PTR2COD E^DGUTL4(+ DGNODE,1,4 ) ;(VALUE, TYPE CODE)  where +DG NODE=race  ien, 1=RAC E and 4=PT F "RTN","D GPTRI4",91 ,0) .S DGR ACE=DGRACE _$S(DGX="" :" ",1:DGX )"RTN","DG PTRI4",92, 0) .S DGX= $$PTR2CODE ^DGUTL4(+$ P(DGNODE," ^",2),3,4)  ;(VALUE,T YPE,CODE)  where $P(D GNODE,U,2) =collectio n method i en, 3=COLL ECTION TYP E and 4=PT F"RTN","DG PTRI4",93, 0) .S DGRA CE=DGRACE_ $S(DGX="": " ",1:DGX) "RTN","DGP TRI4",94,0 ) .S DGNUM =DGNUM+1"R TN","DGPTR I4",95,0)  S DGX="" S  $P(DGX,"  ",12)="""R TN","DGPTR I4",96,0)  S DGRACE=$ S(DGRACE=" ":"  ",1:D GRACE)_DGX "RTN","DGP TRI4",97,0 ) S DGY=DG Y_$E(DGRAC E,1,12)"RT N","DGPTRI 4",98,0) Q  DGY"RTN", "DGPTRI4", 99,0) ;"RT N","DGPTRI 4",100,0)N 701(PTF,DG T1) ;creat e 701 segm ent"RTN"," DGPTRI4",1 01,0) N NO DE,DFN,I,I ENS,IENS2, X"RTN","DG PTRI4",102 ,0) N NNAM E ;node na me"RTN","D GPTRI4",10 3,0) N DTM ,DDDIS,TDI S,DSPEC,TY DIS,PDIS,S A,X,I,RACE A,D1ONLY,D DATE,SC,SH AD,DGCLV"R TN","DGPTR I4",104,0)  N VAA,ASI H"RTN","DG PTRI4",105 ,0) S DGT1 =$G(DGT1)  ;aka T1"RT N","DGPTRI 4",106,0)  S NNAME=$S (DGT1:"C70 1",1:"N701 ")"RTN","D GPTRI4",10 7,0) S IEN S=PTF_","" RTN","DGPT RI4",108,0 ) S DFN=$$ GET1^DIQ(4 5,IENS,.01 ,"I"),IENS 2=DFN_","" RTN","DGPT RI4",109,0 ) S NODE=$ $CDATA^DGP TRNU1(PTF, NNAME) ;co ntrol data "RTN","DGP TRI4",110, 0) S (DDAT E,DTM)=$$D ISP^DGPTRN U(PTF) ;da te of disp osition"RT N","DGPTRI 4",111,0)  S DDIS=$$F DATE^DGPTR NU($P(DTM, ".",1)) ;d ate in MMD DYY format "RTN","DGP TRI4",112, 0) S TDIS= $$TIME^DGP TRNU(DTM)  ;time in H HMM format "RTN","DGP TRI4",113, 0) S:TDIS' ?4N TDIS=" 0000" ;sen d zeros if  time is b lank"RTN", "DGPTRI4", 114,0) S $ E(NODE,31, 36)=DDIS"R TN","DGPTR I4",115,0)  S $E(NODE ,37,40)=TD IS"RTN","D GPTRI4",11 6,0) S DSP EC=$$GET1^ DIQ(45,IEN S,71,"I")  ;discharge  specialty  (pointer  to file #4 2.4)"RTN", "DGPTRI4", 117,0) S $ E(NODE,41, 42)=$$SPEC 2PTF^DGPTR NU1(DSPEC)  ;PTF code "RTN","DGP TRI4",118, 0) S $E(NO DE,43)=$$T DIS^DGPTRN U1(PTF) ;t ype of dis position"R TN","DGPTR I4",119,0)  S $E(NODE ,44)=$$GET 1^DIQ(45,I ENS,73,"I" ) ;outpati ent care s tatus"RTN" ,"DGPTRI4" ,120,0) S  VAA=$$GET1 ^DIQ(45,IE NS,74,"I") "RTN","DGP TRI4",121, 0) S $E(NO DE,45)=$S( VAA=2:2,VA A=1:1,1:"  ") ;VA aus pices"RTN" ,"DGPTRI4" ,122,0) S  $E(NODE,46 )=$$PDIS^D GPTRNU(PTF ) ;place o f disposit ion"RTN"," DGPTRI4",1 23,0) S $E (NODE,47,4 9)=$$GET1^ DIQ(45,IEN S,76.1) ;r eceiving f acility"RT N","DGPTRI 4",124,0)  S $E(NODE, 50,52)=$$G ET1^DIQ(45 ,IENS,76.2 ) ;receivi ng facilit y suffix"R TN","DGPTR I4",125,0)  S ASIH=$$ GET1^DIQ(4 5,IENS,77)  ;asih day s"RTN","DG PTRI4",126 ,0) S ASIH =$S(ASIH>9 99:999,1:A SIH)"RTN", "DGPTRI4", 127,0) S A SIH=$$JUST IFY^DGPTRN U1(ASIH,3, "0","R")"R TN","DGPTR I4",128,0)  S $E(NODE ,53,55)=$S (ASIH="000 ":"   ",1: ASIH) ;asi h days"RTN ","DGPTRI4 ",129,0) S  $E(NODE,5 6)="X" ;wa s race, bu t now is X "RTN","DGP TRI4",130, 0) S $E(NO DE,57)=$$G ET1^DIQ(45 ,IENS,78," I") ;C&P s tatus"RTN" ,"DGPTRI4" ,131,0) S  $E(NODE,58 ,64)=$$FMT ICD^DGPTRN U($$GET1^D IQ(45,IENS ,79)) ;DXL S"RTN","DG PTRI4",132 ,0) S $E(N ODE,65)=$$ GET1^DIQ(4 5,IENS,82. 01,"I") ;P OA for DXL S"RTN","DG PTRI4",133 ,0) S D1ON LY=$$DXLSO NLY^DGPTRN U1(PTF) ;D XLS only ( no seconda ry diagnos es)"RTN"," DGPTRI4",1 34,0) S $E (NODE,66)= $S(D1ONLY: "X",1:" ") "RTN","DGP TRI4",135, 0) ;S X="" ,Z=+$O(^DG PT(PTF,535 ,"AM",$P(D DATE,".")- .0000001))  I $D(^DGP T(PTF,535, +$O(^(Z,0) ),0)) S X= ^(0) ;FT 4 /1/15"RTN" ,"DGPTRI4" ,136,0) S  X="",Z=+$O (^DGPT(PTF ,535,"AM", DDATE-.000 0001)) I $ D(^DGPT(PT F,535,+$O( ^(Z,0)),0) ) S X=^(0)  ;FT 4/1/1 5"RTN","DG PTRI4",137 ,0) ;S DSP EC=$$GET1^ DIQ(45,IEN S,71,"I")  ;discharge  specialty "RTN","DGP TRI4",138, 0) S $E(NO DE,67,72)= $$FMTMPCR^ DGPTRNU1($ P(X,U,16))  ;physical  location  CDR code"R TN","DGPTR I4",139,0)  S $E(NODE ,73,74)=$$ SPEC2PTF^D GPTRNU1($P (X,U,2)) ; physical l ocation (s pecialty)" RTN","DGPT RI4",140,0 ) S SC=$$G ET1^DIQ(2, IENS2,.302 ) ;SC perc entage"RTN ","DGPTRI4 ",141,0) S  $E(NODE,7 5,77)=$$RJ ^XLFSTR(SC ,"3T",0) ; pad with l eading zer os"RTN","D GPTRI4",14 2,0) S $E( NODE,78)="  " ;Legion naire's di sease (not  used)"RTN ","DGPTRI4 ",143,0) S  $E(NODE,7 9)=" " ;su icide indi cator (not  used)"RTN ","DGPTRI4 ",144,0) S  $E(NODE,8 0,83)=" "  ;substance  abuse (no t used)"RT N","DGPTRI 4",145,0)  ;positions  84-88 are  not used  with ICD-1 0"RTN","DG PTRI4",146 ,0) S X=$$ GET1^DIQ(4 5,IENS,79. 25,"I") ;t reated for  SC condit ion"RTN"," DGPTRI4",1 47,0) S $E (NODE,89)= $S(X="Y":" Y",X="N":" N",1:" ")" RTN","DGPT RI4",148,0 ) S $E(NOD E,90)=$$AO ^DGPTRNU(P TF) ;treat ed for AO  condition" RTN","DGPT RI4",149,0 ) S $E(NOD E,91)=$$IO N2^DGPTRNU (PTF) ;tre ated for i onizing ra diation"RT N","DGPTRI 4",150,0)  S $E(NODE, 92)=$$SWAS IA^DGPTRNU (PTF) ;tre atment rel ated to se rvice in S W Asia"RTN ","DGPTRI4 ",151,0) S  $E(NODE,9 3)=$$MST^D GPTRNU(PTF ) ;treatme nt for/rel ated to MS T"RTN","DG PTRI4",152 ,0) S $E(N ODE,94)=$$ HNC^DGPTRN U(PTF) ;tr eatment fo r HNC"RTN" ,"DGPTRI4" ,153,0) S  $E(NODE,95 ,96)=$$ETH NIC(PTF) ; ethnicity" RTN","DGPT RI4",154,0 ) S $E(NOD E,97,108)= $$RACE(PTF ) ;Up to 6  active en tries for  RACE INFOR MATION"RTN ","DGPTRI4 ",155,0) S  X=$$GET1^ DIQ(45,IEN S,79.31,"I ")"RTN","D GPTRI4",15 6,0) S $E( NODE,109)= $S(X="Y":" Y",X="N":" N",1:" ")  ;related t o combat"R TN","DGPTR I4",157,0)  S SHAD=$$ SHAD^DGPTR NU(PTF) ;t reatment f or shad"RT N","DGPTRI 4",158,0)  S $E(NODE, 110)=$S(SH AD=1:"Y",S HAD=0:"N", 1:" ") ;1= Yes, 0=No" RTN","DGPT RI4",159,0 ) S $E(NOD E,114)=$$C LV^DGPTRNU (PTF) ;tre atment rel ated to se rvice at C amp Lejeun e"RTN","DG PTRI4",160 ,0) Q NODE "RTN","DGP TRI4",161, 0) ;"RTN", "DGPTRI4", 162,0)N702 (PTF) ;cre ate 702 se gment"RTN" ,"DGPTRI4" ,163,0) N  NODE,I,IEN S,DGDX,DGL OOP,DGPOA, DGSTRING,D GPTTMP"RTN ","DGPTRI4 ",164,0) N  NNAME ;no de name"RT N","DGPTRI 4",165,0)  N DTM,DDIS ,TDIS,DXCO DES,EFFDAT E,IMPDATE" RTN","DGPT RI4",166,0 ) S IENS=P TF_",""RTN ","DGPTRI4 ",167,0) S  NNAME="N7 02""RTN"," DGPTRI4",1 68,0) S NO DE=$$CDATA ^DGPTRNU1( PTF,NNAME)  ;control  data"RTN", "DGPTRI4", 169,0) S D TM=$$GET1^ DIQ(45,IEN S,70,"I")  ;date/time  of discha rge"RTN"," DGPTRI4",1 70,0) S DD IS=$$FDATE ^DGPTRNU($ P(DTM,".", 1)) ;date  in MMDDYY  format"RTN ","DGPTRI4 ",171,0) S  TDIS=$$TI ME^DGPTRNU (DTM) ;tim e in HHMM  format"RTN ","DGPTRI4 ",172,0) S :TDIS'?4N  TDIS="0000 " ;send ze ros if tim e is blank "RTN","DGP TRI4",173, 0) S $E(NO DE,31,36)= DDIS"RTN", "DGPTRI4", 174,0) S $ E(NODE,37, 40)=TDIS"R TN","DGPTR I4",175,0)  D EFFDATE ^DGPTIC10( PTF) ;get  effective  date to ch eck icd ve rsion of d x codes"RT N","DGPTRI 4",176,0)  D PTFICD^D GPTFUT(701 ,PTF,,.DXC ODES) ;get  secondary  dx and po a values"R TN","DGPTR I4",177,0)  S DGLOOP= 0,DGSTRING ="""RTN"," DGPTRI4",1 78,0) F  S  DGLOOP=$O (DXCODES(D GLOOP)) Q: DGLOOP=""   D  ;ignor e DXCODES( 0). It is  sent in 70 1 segment. "RTN","DGP TRI4",179, 0) .S DGPT TMP=$$ICDD ATA^ICDXCO DE("DIAG", $P(DXCODES (DGLOOP),U ,1),EFFDAT E,"I") ;ge t dx code  info"RTN", "DGPTRI4", 180,0) .I  +DGPTTMP>0 &($P(DGPTT MP,U,10))  D  ;check  ien and st atus"RTN", "DGPTRI4", 181,0) ..S  DGDX=$P(D XCODES(DGL OOP),U,3)  ;dx extern al value"R TN","DGPTR I4",182,0)  ..S DGDX= $$FMTICD^D GPTRNU(DGD X) ;remove  decimal p oint"RTN", "DGPTRI4", 183,0) ..S  DGDX=$$LJ ^XLFSTR(DG DX,7," ")  ;left just ify & add  spaces to  the right  to reach 7  character s"RTN","DG PTRI4",184 ,0) ..S DG POA=$P(DXC ODES(DGLOO P),U,2) ;g et poa cod e"RTN","DG PTRI4",185 ,0) ..S DG POA=$S(DGP OA'="":DGP OA,1:" ")  ;use space , if no PO A code"RTN ","DGPTRI4 ",186,0) . .S DGSTRIN G=DGSTRING _DGDX_DGPO A ;build s tring of d x and poa  values"RTN ","DGPTRI4 ",187,0) S  $E(NODE,4 1,232)=DGS TRING_$$RE PEAT^XLFST R(" ",192- $L(DGSTRIN G))"RTN"," DGPTRI4",1 88,0) Q NO DE"RTN","D GPTRI4",18 9,0) ;"RTN ","DGPTRNU ")0^65^B57 839149"RTN ","DGPTRNU ",1,0)DGPT RNU ;ISF/G JW,HIOFO/F T - PTF TR ANSMISSION  ;2/18/15  2:28pm"RTN ","DGPTRNU ",2,0) ;;5 .3;Registr ation;**88 4,914**;Au g 13, 1993 ;Build 104 "RTN","DGP TRNU",3,0)  ;"RTN","D GPTRNU",4, 0) ;XLFDT  - #10103"R TN","DGPTR NU",5,0) ; "RTN","DGP TRNU",6,0) FDATE(DGDT ,DGDF) ;fo rmat date  as MMDDYY" RTN","DGPT RNU",7,0)  ;Format op tions"RTN" ,"DGPTRNU" ,8,0) ;1 -  MMDDYY"RT N","DGPTRN U",9,0) ;2  - MMDDYYY Y"RTN","DG PTRNU",10, 0) N X,MON ,DAY,YR,VA L"RTN","DG PTRNU",11, 0) S DGDF= $G(DGDF,1)  ;default  to 2-digit  date"RTN" ,"DGPTRNU" ,12,0) S X =$$FMTE^XL FDT(DGDT," 5ZP")"RTN" ,"DGPTRNU" ,13,0) S M ON=$P(X,"/ ")"RTN","D GPTRNU",14 ,0) S DAY= $P(X,"/",2 )"RTN","DG PTRNU",15, 0) S YR=$P (X,"/",3)" RTN","DGPT RNU",16,0)  S:DGDF=1  VAL=MON_DA Y_$E(YR,3, 4)"RTN","D GPTRNU",17 ,0) S:DGDF =2 VAL=MON _DAY_YR"RT N","DGPTRN U",18,0) Q  $S(+DGDT' >0:"",1:VA L)"RTN","D GPTRNU",19 ,0) ;"RTN" ,"DGPTRNU" ,20,0)TIME (DTM) ;ext ract time  in HHMM fo rmat from  date/time" RTN","DGPT RNU",21,0)  N X,Y,H,M "RTN","DGP TRNU",22,0 ) S X=$$FM TE^XLFDT(D TM,"6F")"R TN","DGPTR NU",23,0)  S Y=$P(X," @",2)"RTN" ,"DGPTRNU" ,24,0) S H =$P(Y,":") ,M=$P(Y,": ",2)"RTN", "DGPTRNU", 25,0) Q H_ M"RTN","DG PTRNU",26, 0) ;"RTN", "DGPTRNU", 27,0)FMTIC D(DGC) ;fo rmat ICD c ode for tr ansmission "RTN","DGP TRNU",28,0 ) Q $TR(DG C,".","")" RTN","DGPT RNU",29,0)  ;"RTN","D GPTRNU",30 ,0) ;Retri eve nodes  from PTF C LOSE OUT ( #45.84) wh ere approp riate"RTN" ,"DGPTRNU" ,31,0)GETN ODE(DGPTF, DGHOW,DGNO DE) ;"RTN" ,"DGPTRNU" ,32,0) ;DG HOW = 1 -  use PTF CL OSE OUT no de if defi ned, PTF o therwise"R TN","DGPTR NU",33,0)  ;DGHOW = 2  - use PTF  file"RTN" ,"DGPTRNU" ,34,0) ;DG HOW = 3 -  use PTF CL OSE OUT re cord (forc ed)"RTN"," DGPTRNU",3 5,0) N VAL ,DFN,COUT, IENS45,IEN S2,FLD,NOD E"RTN","DG PTRNU",36, 0) ;the fi eld number s for the  various ST ORE(*) fie lds"RTN"," DGPTRNU",3 7,0) S NOD E=$S(DGNOD E=0:0,DGNO DE=32:.32, DGNODE=321 :.321,DGNO DE=52:.52, 1:"")"RTN" ,"DGPTRNU" ,38,0) S F LD=$S(DGNO DE=0:10,DG NODE=11:11 ,DGNODE=52 :12,DGNODE =321:13,DG NODE=32:14 ,DGNODE=57 :15,.3:16, 1:0)"RTN", "DGPTRNU", 39,0) S VA L="""RTN", "DGPTRNU", 40,0) S IE NS45=DGPTF _",""RTN", "DGPTRNU", 41,0) S CO UT=$$GET1^ DIQ(45,IEN S45,7.1,"I ") ;corres ponding en try in PTF  CLOSE OUT  file"RTN" ,"DGPTRNU" ,42,0) S D FN=$$GET1^ DIQ(45,IEN S45,.01,"I ") ;ft 2/1 2/15"RTN", "DGPTRNU", 43,0) I DG HOW'=3 D"R TN","DGPTR NU",44,0)  .S DFN=$$G ET1^DIQ(45 ,IENS45,.0 1,"I")"RTN ","DGPTRNU ",45,0) .S  IENS2=$G( DFN)_",""R TN","DGPTR NU",46,0)  I DGHOW=1  S VAL=$S(C OUT:$$GET1 ^DIQ(45.84 ,COUT_",", FLD),1:$G( ^DPT(DFN,D GNODE)))"R TN","DGPTR NU",47,0)  I DGHOW=2  S VAL=$G(^ DPT(DFN,.3 21))"RTN", "DGPTRNU", 48,0) I DG HOW=3 S VA L=$$GET1^D IQ(45.84,C OUT_",",FL D)"RTN","D GPTRNU",49 ,0) Q VAL" RTN","DGPT RNU",50,0)  ;"RTN","D GPTRNU",51 ,0) ;conve nience rou tines for  commonly u sed nodes" RTN","DGPT RNU",52,0) GET0(DGPTF ,DGHOW) ;" RTN","DGPT RNU",53,0)  S DGHOW=$ G(DGHOW,1) "RTN","DGP TRNU",54,0 ) Q $$GETN ODE(DGPTF, DGHOW,0)"R TN","DGPTR NU",55,0)  ;"RTN","DG PTRNU",56, 0)GET32(DG PTF,DGHOW)  ;"RTN","D GPTRNU",57 ,0) S DGHO W=$G(DGHOW ,1)"RTN"," DGPTRNU",5 8,0) Q $$G ETNODE(DGP TF,DGHOW,. 32)"RTN"," DGPTRNU",5 9,0) ;"RTN ","DGPTRNU ",60,0)GET 321(DGPTF, DGHOW) ;"R TN","DGPTR NU",61,0)  S DGHOW=$G (DGHOW,1)" RTN","DGPT RNU",62,0)  Q $$GETNO DE(DGPTF,D GHOW,.321) "RTN","DGP TRNU",63,0 ) ;"RTN"," DGPTRNU",6 4,0)GET52( DGPTF,DGHO W) ;"RTN", "DGPTRNU", 65,0) S DG HOW=$G(DGH OW,1)"RTN" ,"DGPTRNU" ,66,0) Q $ $GETNODE(D GPTF,DGHOW ,.52)"RTN" ,"DGPTRNU" ,67,0) ;"R TN","DGPTR NU",68,0)P OW(DGPTF)  ;POW statu s"RTN","DG PTRNU",69, 0) ;return s"RTN","DG PTRNU",70, 0) ;1 - no t a POW"RT N","DGPTRN U",71,0) ; 3 - POW, u nknown"RTN ","DGPTRNU ",72,0) ;4  - POW, Wo rld War I" RTN","DGPT RNU",73,0)  ;5 - POW,  World War  II (Europ e)"RTN","D GPTRNU",74 ,0) ;6 - P OW, World  War II (Pa cific)"RTN ","DGPTRNU ",75,0) ;7  - POW, Ko rea"RTN"," DGPTRNU",7 6,0) ;8 -  POW, Vietn am"RTN","D GPTRNU",77 ,0) ;9 - P OW, combin ation"RTN" ,"DGPTRNU" ,78,0) N D G52,SI,PP, Y,VAL"RTN" ,"DGPTRNU" ,79,0) S D G52=$$GET5 2^DGPTRNU( DGPTF)"RTN ","DGPTRNU ",80,0) S  SI=$P(DG52 ,U,5) ;POW  status in dicated?," RTN","DGPT RNU",81,0)  S Y=$P(DG 52,U,6) ;P OW period" RTN","DGPT RNU",82,0)  S VAL=1"R TN","DGPTR NU",83,0)  I SI="Y" D "RTN","DGP TRNU",84,0 ) .S VAL=$ S(Y=0:3,Y= 2:5,Y=3:6, Y=4:7,Y=5: 8,Y=6:9,Y= 7:"A",Y=8: "B",1:" ") "RTN","DGP TRNU",85,0 ) Q VAL"RT N","DGPTRN U",86,0) ; "RTN","DGP TRNU",87,0 )PDIS(DGPT F) ;place  of disposi tion"RTN", "DGPTRNU", 88,0) N IE NS,IENS1,X "RTN","DGP TRNU",89,0 ) S IENS=D GPTF_",""R TN","DGPTR NU",90,0)  S X=$$GET1 ^DIQ(45,IE NS,75,"I") ,IENS1=X_" ,""RTN","D GPTRNU",91 ,0) Q $$GE T1^DIQ(45. 6,IENS1,2)  ;PTF code "RTN","DGP TRNU",92,0 ) ;"RTN"," DGPTRNU",9 3,0)POS(DG PTF) ;peri od of serv ice"RTN"," DGPTRNU",9 4,0) N IEN S45,DG32,P OS1,POS,MV ,ELIG"RTN" ,"DGPTRNU" ,95,0) S I ENS45=DGPT F_",""RTN" ,"DGPTRNU" ,96,0) S D G32=$$GET3 2^DGPTRNU( DGPTF)"RTN ","DGPTRNU ",97,0) S  POS1=$P(DG 32,U,3) ;p eriod of s ervice fro m PATIENT  file (poin ter to fil e #21)"RTN ","DGPTRNU ",98,0) S  POS=$$GET1 ^DIQ(21,PO S1_",",.03 ) ;code"RT N","DGPTRN U",99,0) ; Now, use t he "APTF"  cross-refe rence on t he PATIENT  MOVEMENT  (#405) fil e to look  up"RTN","D GPTRNU",10 0,0) ;the  patient mo vement ass ociated wi th this PT F entry"RT N","DGPTRN U",101,0)  S MV="" S: $D(^DGPM(" APTF",PTF) ) MV=$O(^D GPM("APTF" ,PTF,0))"R TN","DGPTR NU",102,0)  ;If the p atient mov ement has  ODS AT ADM ISSION set  (for Oper ation Dese rt Shield) , ensure"R TN","DGPTR NU",103,0)  ;that POS =6 (ODS).  This is ne cessary be cause the  POS may ha ve been se t to anoth er value"R TN","DGPTR NU",104,0)  ;accordin g the busi ness rules ."RTN","DG PTRNU",105 ,0) I +$$G ET1^DIQ(40 5,MV_",",1 1500.01)>0  S POS=6"R TN","DGPTR NU",106,0)  S ELIG=$$ GET1^DIQ(4 5,IENS45,2 0.1,"I") ; admitting  eligibilit y"RTN","DG PTRNU",107 ,0) S POS= $$CKPOS^DG PTUTL(ELIG ,POS) ;upd ate POS (t o account  for non-ve t eligibil ities)"RTN ","DGPTRNU ",108,0) Q  POS"RTN", "DGPTRNU", 109,0) ;"R TN","DGPTR NU",110,0) MSTATUS(DG PTF) ;mari tal status "RTN","DGP TRNU",111, 0) N IENS4 5,DFN,IENS ,X,MS"RTN" ,"DGPTRNU" ,112,0) S  IENS45=DGP TF_",""RTN ","DGPTRNU ",113,0) S  DFN=$$GET 1^DIQ(45,I ENS45,.01, "I"),IENS= DFN_",""RT N","DGPTRN U",114,0)  S X=$$GET1 ^DIQ(2,IEN S,.05,"I") "RTN","DGP TRNU",115, 0) S MS=$$ GET1^DIQ(1 1,X_",",2, "I")"RTN", "DGPTRNU", 116,0) S:M S="" MS="U ""RTN","DG PTRNU",117 ,0) Q MS"R TN","DGPTR NU",118,0)  ;"RTN","D GPTRNU",11 9,0)ION(DG PTF) ;ioni zing radia tion (used  by 101)"R TN","DGPTR NU",120,0)  ;return v alue"RTN", "DGPTRNU", 121,0) ;1  - no claim  of exposu re"RTN","D GPTRNU",12 2,0) ;2 -  claims exp osure, Jap an"RTN","D GPTRNU",12 3,0) ;3 -  claims exp osure, tes ting"RTN", "DGPTRNU", 124,0) ;4  - claims e xposure, b oth testin g and Japa n"RTN","DG PTRNU",125 ,0) ;5 - c laims expo sure, unde rground nu clear test ing"RTN"," DGPTRNU",1 26,0) ;6 -  claims ex posure, nu clear faci lity"RTN", "DGPTRNU", 127,0) ;7  - claims e xposure, o ther"RTN", "DGPTRNU", 128,0) N D G321,DGNT, DGPOS,RE,E ,VPOS"RTN" ,"DGPTRNU" ,129,0) S  DG321=$$GE T321^DGPTR NU(DGPTF)" RTN","DGPT RNU",130,0 ) S DGNT=$ P(DG321,U, 12) ;radia tion expos ure method "RTN","DGP TRNU",131, 0) S RE=$P (DG321,U,3 ) ;radiati on exposur e indicate d"RTN","DG PTRNU",132 ,0) S E="  ""RTN","DG PTRNU",133 ,0) S DGPO S=$$POS(DG PTF)"RTN", "DGPTRNU", 134,0) ;va lid POS fo r ionizing  radiation ?"RTN","DG PTRNU",135 ,0) S VPOS =$S(DGPOS= 0:1,DGPOS= 2:1,DGPOS= 4:1,DGPOS= 5:1,DGPOS= 7:1,DGPOS= 8:1,DGPOS= "Z":1,1:0) "RTN","DGP TRNU",136, 0) D:VPOS" RTN","DGPT RNU",137,0 ) .S E=$S( RE'="Y":1, 1:DGNT)"RT N","DGPTRN U",138,0)  Q E"RTN"," DGPTRNU",1 39,0) ;"RT N","DGPTRN U",140,0)I ON2(DGPTF)  ;ionizing  radiation  (used by  701)"RTN", "DGPTRNU", 141,0) ;re turns Y(es ), N(o) or  space"RTN ","DGPTRNU ",142,0) N  G"RTN","D GPTRNU",14 3,0) S G=$ $GET1^DIQ( 45,DGPTF_" ,",79.27," I")"RTN"," DGPTRNU",1 44,0) Q $S (G="Y":"Y" ,G="N":"N" ,1:" ")"RT N","DGPTRN U",145,0)  ;"RTN","DG PTRNU",146 ,0)MST(DGP TF) ;milit ary sexual  trauma"RT N","DGPTRN U",147,0)  N IENS,X,Y "RTN","DGP TRNU",148, 0) S IENS= DGPTF_","" RTN","DGPT RNU",149,0 ) S Y=$$GE T1^DIQ(45, IENS,79.29 ,"I")"RTN" ,"DGPTRNU" ,150,0) Q  $S(Y="Y":" Y",Y="N":" N",1:" ")" RTN","DGPT RNU",151,0 ) ;"RTN"," DGPTRNU",1 52,0)HNC(D GPTF) ;tre atment rel ated to he ad/neck ca ncer (HNC) "RTN","DGP TRNU",153, 0) N Y,IEN S"RTN","DG PTRNU",154 ,0) S IENS =DGPTF_"," "RTN","DGP TRNU",155, 0) S Y=$$G ET1^DIQ(45 ,IENS,79.3 ,"I")"RTN" ,"DGPTRNU" ,156,0) Q  $S(Y="Y":" Y",Y="N":" N",1:" ")" RTN","DGPT RNU",157,0 ) ;"RTN"," DGPTRNU",1 58,0)SWASI A(DGPTF) ; treatment  related to  service i n SW Asia" RTN","DGPT RNU",159,0 ) N Y,IENS "RTN","DGP TRNU",160, 0) S IENS= DGPTF_","" RTN","DGPT RNU",161,0 ) S Y=$$GE T1^DIQ(45, IENS,79.28 )"RTN","DG PTRNU",162 ,0) Q $S(Y ="":" ",1: Y)"RTN","D GPTRNU",16 3,0) ;"RTN ","DGPTRNU ",164,0)CV S(DGPTF) ; combat vet  status"RT N","DGPTRN U",165,0)  ;returns 1 =yes, 2=no "RTN","DGP TRNU",166, 0) N DG0,I ENS,DFN,Y, ADATE"RTN" ,"DGPTRNU" ,167,0) S  DG0=$$GET0 ^DGPTRNU(D GPTF)"RTN" ,"DGPTRNU" ,168,0) S  IENS=DGPTF _",""RTN", "DGPTRNU", 169,0) S D FN=$$GET1^ DIQ(45,IEN S,.01,"I") "RTN","DGP TRNU",170, 0) S ADATE =$P(DG0,U, 2) ;admiss ion date"R TN","DGPTR NU",171,0)  I ADATE S  Y=$$CVEDT ^DGCV(DFN, ADATE)"RTN ","DGPTRNU ",172,0) E   S Y=$$CV EDT^DGCV(D FN,ADATE)" RTN","DGPT RNU",173,0 ) Q $S(+Y> 0:1,1:2)"R TN","DGPTR NU",174,0)  ;"RTN","D GPTRNU",17 5,0)CVDT(D GPTF) ;com bat vet da te"RTN","D GPTRNU",17 6,0) N DG0 ,IENS,DFN, ADATE,Y"RT N","DGPTRN U",177,0)  S DG0=$$GE T0^DGPTRNU (DGPTF)"RT N","DGPTRN U",178,0)  S IENS=DGP TF_",""RTN ","DGPTRNU ",179,0) S  DFN=$$GET 1^DIQ(45,I ENS,.01,"I ")"RTN","D GPTRNU",18 0,0) S ADA TE=+$P(DG0 ,U,2) ;adm ission dat e"RTN","DG PTRNU",181 ,0) I ADAT E S Y=$$CV EDT^DGCV(D FN,ADATE)" RTN","DGPT RNU",182,0 ) E  S Y=$ $CVEDT^DGC V(DFN)"RTN ","DGPTRNU ",183,0) Q  $S(+Y>0:$ P(Y,U,2),1 :0)"RTN"," DGPTRNU",1 84,0) ;"RT N","DGPTRN U",185,0)S HAD(DGPTF)  ;SHAD/Pro ject 112"R TN","DGPTR NU",186,0)  N IENS,Y" RTN","DGPT RNU",187,0 ) S IENS=D GPTF_",""R TN","DGPTR NU",188,0)  S Y=$$GET 1^DIQ(45,I ENS,79.32, "I")"RTN", "DGPTRNU", 189,0) Q $ S(Y="":" " ,1:Y)"RTN" ,"DGPTRNU" ,190,0) ;" RTN","DGPT RNU",191,0 )CLV(DGPTF ) ;Camp Le jeune Vete rans"RTN", "DGPTRNU", 192,0) ;Y  - yes"RTN" ,"DGPTRNU" ,193,0) ;N  - no"RTN" ,"DGPTRNU" ,194,0) ;"  " - unkno wn or no v alue"RTN", "DGPTRNU", 195,0) N D GCLV"RTN", "DGPTRNU", 196,0) S D GCLV=$$GET 1^DIQ(45,D GPTF_",",7 9.33,"I")" RTN","DGPT RNU",197,0 ) Q $S(DGC LV="Y":"Y" ,DGCLV="N" :"N",1:" " )"RTN","DG PTRNU",198 ,0) ;"RTN" ,"DGPTRNU" ,199,0)KAT RINA(DGPTF ) ;Katrina  indicator "RTN","DGP TRNU",200, 0) N DFN,D G0,ERI"RTN ","DGPTRNU ",201,0) S  IENS=DGPT F_",""RTN" ,"DGPTRNU" ,202,0) S  DG0=$$GET0 (DGPTF),DF N=+DG0"RTN ","DGPTRNU ",203,0) S  ERI=$$EMG RES^DGUTL( DFN) ;emer gency resp onse indic ator"RTN", "DGPTRNU", 204,0) ;re turns "K"  or " ""RTN ","DGPTRNU ",205,0) Q  $S("^K^"[ (U_ERI_U): "K",1:" ") "RTN","DGP TRNU",206, 0) ;"RTN", "DGPTRNU", 207,0)MTI( DGPTF) ;me ans test i ndicator"R TN","DGPTR NU",208,0)  ;return v alue"RTN", "DGPTRNU", 209,0) ;AS  - SC and  special ca tegory vet erans"RTN" ,"DGPTRNU" ,210,0) ;A N - NSC ve terans"RTN ","DGPTRNU ",211,0) ; B -  categ ory "B" NS C veterans "RTN","DGP TRNU",212, 0) ;C -  M T copay re quired (ca tegory "C"  NSC veter ans)"RTN", "DGPTRNU", 213,0) ;N  -  non-vet erans"RTN" ,"DGPTRNU" ,214,0) ;X  -  not ap plicable"R TN","DGPTR NU",215,0)  ;U -  not  done/comp leted"RTN" ,"DGPTRNU" ,216,0) ;G  -  GMT co pay requir ed"RTN","D GPTRNU",21 7,0) N VAL ,IENS,MT,A O"RTN","DG PTRNU",218 ,0) S VAL= "  ""RTN", "DGPTRNU", 219,0) S I ENS=DGPTF_ ",""RTN"," DGPTRNU",2 20,0) S AO =$$GET1^DI Q(45.84,IE NS,79.26," I") ;treat ed for AO  condition" RTN","DGPT RNU",221,0 ) S MT=$$G ET1^DIQ(45 .84,IENS,1 0,"I") ;me ans test i ndicator"R TN","DGPTR NU",222,0)  S MT=$S(M T="":"U",1 :MT)"RTN", "DGPTRNU", 223,0) S V AL=$S(AO=" Y":"AS",1: MT)"RTN"," DGPTRNU",2 24,0) Q VA L"RTN","DG PTRNU",225 ,0) ;"RTN" ,"DGPTRNU" ,226,0)AO( DGPTF) ;tr eated for  agent oran ge exposur e (used by  701)"RTN" ,"DGPTRNU" ,227,0) ;Y  - yes"RTN ","DGPTRNU ",228,0) ; N - no"RTN ","DGPTRNU ",229,0) ; " " - unkn own or no  value"RTN" ,"DGPTRNU" ,230,0) N  G"RTN","DG PTRNU",231 ,0) S G=$$ GET1^DIQ(4 5,DGPTF_", ",79.26,"I ")"RTN","D GPTRNU",23 2,0) Q $S( G="Y":"Y", G="N":"N", 1:" ")"RTN ","DGPTRNU ",233,0) ; "RTN","DGP TRNU",234, 0)AO2(DGPT F) ;agent  orange exp osure (use d by 101)" RTN","DGPT RNU",235,0 ) ;return  value:"RTN ","DGPTRNU ",236,0) ; 1 - no cla im of serv ice in Vie tnam"RTN", "DGPTRNU", 237,0) ;2  - claims s ervice in  Vietnam, n o exposure "RTN","DGP TRNU",238, 0) ;3 - cl aims servi ce in Viet nam with e xposure"RT N","DGPTRN U",239,0)  ;4 - claim s service  in Vietnam  with expo sure unkno wn"RTN","D GPTRNU",24 0,0) ;5 -  claims ser vice in DM Z with exp osure"RTN" ,"DGPTRNU" ,241,0) ;m ay return  blank"RTN" ,"DGPTRNU" ,242,0) N  G,DGAO,DGP OS,DG321"R TN","DGPTR NU",243,0)  S DG321=$ $GET321(DG PTF)"RTN", "DGPTRNU", 244,0) S G =" ""RTN", "DGPTRNU", 245,0) S D GAO=$P(DG3 21,U,2)"RT N","DGPTRN U",246,0)  S DGPOS=$$ POS^DGPTRN U(DGPTF)"R TN","DGPTR NU",247,0)  S:DGPOS=7  G=$S($P(D G321,U)'=" Y":1,DGAO= "N":2,DGAO ="Y":3,1:4 )"RTN","DG PTRNU",248 ,0) ;Check  to see if  the expos ure locati on was the  Korean DM Z"RTN","DG PTRNU",249 ,0) S:(DGA O="Y")&($P (DG321,U,1 3)="K") G= 5"RTN","DG PTRNU",250 ,0) Q G"RT N","DGPTRN U",251,0)  ;"RTN","DG PTRNU",252 ,0)INCOME( DGPTF) ;in come"RTN", "DGPTRNU", 253,0) N I NC,IENS,LI ,PAD"RTN", "DGPTRNU", 254,0) S I ENS=DGPTF_ ",""RTN"," DGPTRNU",2 55,0) S IN C=$$GET1^D IQ(45,IENS ,101.07)"R TN","DGPTR NU",256,0)  S:INC>999 999 INC=99 9999"RTN", "DGPTRNU", 257,0) S L I=$L(INC)" RTN","DGPT RNU",258,0 ) S PAD=$S (LI=0:"000 000",LI=1: "00000",LI =2:"0000", LI=3:"000" ,LI=4:"00" ,LI=5:"0", 1:"")"RTN" ,"DGPTRNU" ,259,0) Q  PAD_INC"RT N","DGPTRN U",260,0)  ;"RTN","DG PTRNU",261 ,0)DISP(PT F) ;date o f disposit ion"RTN"," DGPTRNU",2 62,0) N IE NS"RTN","D GPTRNU",26 3,0) S IEN S=PTF_","" RTN","DGPT RNU",264,0 ) Q $$GET1 ^DIQ(45,IE NS,70,"I")  ;discharg e date"RTN ","DGPTRNU ",265,0) ; "RTN","DGP TRNU",266, 0)GETMPCR( DGTS) ;MPC R from spe cialty"RTN ","DGPTRNU ",267,0)   N ARRY,Y,Z ,MPCR"RTN" ,"DGPTRNU" ,268,0)  S  Y=$$TSDAT A^DGACT(42 .4,DGTS,.A RRY)"RTN", "DGPTRNU", 269,0)  S  Z=$G(ARRY( 6))"RTN"," DGPTRNU",2 70,0)  I Y >0 S MPCR= $E($P(Z,". ")_"0000", 1,4)_$E($P (Z,".",2)_ "00",1,2)" RTN","DGPT RNU",271,0 )  E  S MP CR="""RTN" ,"DGPTRNU" ,272,0)  Q  MPCR"RTN" ,"DGPTRNU" ,273,0)  ; "RTN","DGP TRNU",274, 0)SPCODE(D GTS) ;"RTN ","DGPTRNU ",275,0) N  ARRY,Y,Z" RTN","DGPT RNU",276,0 ) S Y=$$TS DATA^DGACT (42.4,DGTS ,.ARRY)"RT N","DGPTRN U",277,0)  S Z=$G(ARR Y(6))"RTN" ,"DGPTRNU" ,278,0) Q  $S(Y>0:Z,1 :"")"RTN", "DGPTRNU", 279,0) ;"R TN","DGPTR NU",280,0) RACE(DGPTF ,DGARR) ;" RTN","DGPT RNU",281,0 ) N IENS45 ,IENS,DFN" RTN","DGPT RNU",282,0 ) N OUT,MO UT"RTN","D GPTRNU",28 3,0) N I,N UM,MORE,EV AL,IVAL"RT N","DGPTRN U",284,0)  S IENS45=D GPTF_",""R TN","DGPTR NU",285,0)  S DFN=$$G ET1^DIQ(45 ,IENS45,.0 1,"I"),IEN S=","_DFN_ ",""RTN"," DGPTRNU",2 86,0) ;ret rieve at m ost 6 entr ies, scree ning out t hose that  are inacti ve"RTN","D GPTRNU",28 7,0) D LIS T^DIC(2.02 ,IENS,".01 ",,6,,,,"I  '$$INACTI VE^DGUTL4( Y)",,"OUT" ,"MOUT")"R TN","DGPTR NU",288,0)  S NUM=$P( OUT("DILIS T",0),U) ; number of  subrecords  returned" RTN","DGPT RNU",289,0 ) S MORE=$ P(OUT("DIL IST",0),U, 3) ;anymor e?"RTN","D GPTRNU",29 0,0) F I=1 :1:NUM D"R TN","DGPTR NU",291,0)  .S EVAL=$ G(OUT("DIL IST",1,I)) "RTN","DGP TRNU",292, 0) .S IVAL =$G(OUT("D ILIST",2,I ))"RTN","D GPTRNU",29 3,0) .S @D GARR@(I,"I EN")=IVAL" RTN","DGPT RNU",294,0 ) .S @DGAR R@(I,"VAL" )=EVAL"RTN ","DGPTRNU ",295,0) . S @DGARR@( I,"CODE")= $$PTR2CODE ^DGUTL4(IV AL,1,4)"RT N","DGPTRN U",296,0)  Q"RTN","DG PTSPQ")0^6 0^B1442720 2"RTN","DG PTSPQ",1,0 )DGPTSPQ ; ALB/MTC -  PTF Utilit y Con ;11/ 26/03 9:56 am"RTN","D GPTSPQ",2, 0) ;;5.3;R egistratio n;**195,39 7,565,664, 914**;Aug  13, 1993;B uild 104"R TN","DGPTS PQ",3,0) ; "RTN","DGP TSPQ",4,0) CHQUES ;--  This func tion will  determine  if the pat ient has a ny of the" RTN","DGPT SPQ",5,0)  ;   follow ing indica ted : AO,  IR, EC, MS T, NTR, CL V"RTN","DG PTSPQ",6,0 ) ;   If s o the arra y DGEXQ wi ll contain :"RTN","DG PTSPQ",7,0 ) ;     DG EXQ(1)=""  - AO"RTN", "DGPTSPQ", 8,0) ;      DGEXQ(2)= "" - IR"RT N","DGPTSP Q",9,0) ;      DGEXQ( 3)="" - SW  Asia Cond itions/EC" RTN","DGPT SPQ",10,0)  ;     DGE XQ(4)="" -  MST  ;add ed 6/17/98  for MST e nhancement "RTN","DGP TSPQ",11,0 ) ;     DG EXQ(5)=""  - NTR  ;tr eatment fo r Head/Nec k CA"RTN", "DGPTSPQ", 12,0) ;                           ;ONLY if  (#28.11) N ose Throat  Radium en tered"RTN" ,"DGPTSPQ" ,13,0) ;      DGEXQ(6 )="" - CV    ;treatme nt for pos sible comb at related  "RTN","DG PTSPQ",14, 0) ;                          ;c ondition"R TN","DGPTS PQ",15,0)  ;     DGEX Q(7)="" -  SHAD ;trea tment for  Project 11 2/SHAD"RTN ","DGPTSPQ ",16,0) ;      DGEXQ( 8)="" - CL V  ;RSD 2. 6.5.1 Camp  Lejeune D G*5.3*914" RTN","DGPT SPQ",17,0)  ;   Other wise they  will be un defined."R TN","DGPTS PQ",18,0)  ; This rou tine is ca lled from  the PTF in put templa tes."RTN", "DGPTSPQ", 19,0) ;    The follow ing variab les are de fined:"RTN ","DGPTSPQ ",20,0) ;      DGHOLD  : Movemen t record b efore any  changes be en made."R TN","DGPTS PQ",21,0)  ;     DGPT F  : PTF R ecord Numb er."RTN"," DGPTSPQ",2 2,0) ;      DGMOV  :  PTF Moveme nt Number  (optional) "RTN","DGP TSPQ",23,0 ) N DGHOLD ,SDCLY"RTN ","DGPTSPQ ",24,0) S  DGHOLD=^DG PT(DA(1)," M",DA,0),S DCLY="""RT N","DGPTSP Q",25,0) ; -- call to  determine  if questi ons should  be asked.  OPC uses  same"RTN", "DGPTSPQ", 26,0) ;    criteria." RTN","DGPT SPQ",27,0)  ; If call ed straigh t from Fil eMan, DFN  won't be d efined so  define it  based on v alue in DA (1)"RTN"," DGPTSPQ",2 8,0) I $G( DFN)="",$G (DA(1))>0  S DFN=$P($ G(^DGPT(DA (1),0)),U, 1)"RTN","D GPTSPQ",29 ,0) ; If c alled stra ight from  FileMan, D GPTF won't  be define d so defin e it based  on value  in DA(1)"R TN","DGPTS PQ",30,0)  I $G(DGPTF )="",$G(DA (1))>0 S D GPTF=$P($G (^DGPT(DA( 1),0)),U,1 )"RTN","DG PTSPQ",31, 0) ;"RTN", "DGPTSPQ", 32,0) D CL ^SDCO21(DF N,$P(DGHOL D,U,10),"" ,.SDCLY)"R TN","DGPTS PQ",33,0)  ;"RTN","DG PTSPQ",34, 0) ;-- if  sc > 50% a nd treated  for sc do n't ask AO /IR"RTN"," DGPTSPQ",3 5,0) ;-- A DD KILL OF  SDCLY(6)  TO SKIP CO MBAT VETER AN QUESTIO N"RTN","DG PTSPQ",36, 0) I $P($G (^DGPT(DGP TF,"M",+$G (DGMOV),0) ),U,18)=1  K SDCLY(1) ,SDCLY(2)" RTN","DGPT SPQ",37,0)  ;"RTN","D GPTSPQ",38 ,0) G:'$D( SDCLY) CHQ "RTN","DGP TSPQ",39,0 ) ; AO"RTN ","DGPTSPQ ",40,0) I  $D(SDCLY(1 )) S DGEXQ (1)="""RTN ","DGPTSPQ ",41,0) ;  IR"RTN","D GPTSPQ",42 ,0) I $D(S DCLY(2)) S  DGEXQ(2)= """RTN","D GPTSPQ",43 ,0) ; SW A sia Condit ions/EC"RT N","DGPTSP Q",44,0) I  $D(SDCLY( 4)) S DGEX Q(3)="""RT N","DGPTSP Q",45,0) ;  MST"RTN", "DGPTSPQ", 46,0) I $D (SDCLY(5))  S DGEXQ(4 )="" ;adde d 6/17/98  for MST en hancement" RTN","DGPT SPQ",47,0)  ; NTR"RTN ","DGPTSPQ ",48,0) I  $D(SDCLY(6 )) S DGEXQ (5)="""RTN ","DGPTSPQ ",49,0) ;  CV"RTN","D GPTSPQ",50 ,0) I $D(S DCLY(7)) S  DGEXQ(6)= """RTN","D GPTSPQ",51 ,0) ; SHAD "RTN","DGP TSPQ",52,0 ) I $D(SDC LY(8)) S D GEXQ(7)="" "RTN","DGP TSPQ",53,0 ) ; Camp L ejeune"RTN ","DGPTSPQ ",54,0) I  $D(SDCLY(9 )) S DGEXQ (8)="" ;RS D 2.6.5.1  Camp Lejeu ne DG*5.3* 914"RTN"," DGPTSPQ",5 5,0)CHQ Q" RTN","DGPT SPQ",56,0)  ;"RTN","D GPTSPQ",57 ,0)501 ;--  This is t he input t ransform l ogic for t he followi ng questio ns:"RTN"," DGPTSPQ",5 8,0) ;   A O, IR, EC,  MST, NTR" RTN","DGPT SPQ",59,0)  ;   Proce ss: Make s ure that t he conditi ons are in dicated be fore"RTN", "DGPTSPQ", 60,0) ;             a llowing da ta to be e ntered. If  the indic ators are" RTN","DGPT SPQ",61,0)  ;             not pr esent and  the questi on was ans wered, DGE R"RTN","DG PTSPQ",62, 0) ;             will  be set to  1."RTN"," DGPTSPQ",6 3,0) ;   I NPUT  : DG FLAG - Fie ld to chec k"RTN","DG PTSPQ",64, 0) ;             DGER    - DGER   error cod e"RTN","DG PTSPQ",65, 0) N DGEXQ "RTN","DGP TSPQ",66,0 ) S DGER=0 "RTN","DGP TSPQ",67,0 ) D CHQUES "RTN","DGP TSPQ",68,0 ) I '$D(DG EXQ(+DGFLA G)) S DGER =1"RTN","D GPTSPQ",69 ,0) Q"RTN" ,"DGPTSPQ" ,70,0) ;"R TN","DGPTS PQ",71,0)7 01 ;-- Thi s is the i nput trans form logic  for the f ollowing q uestions"R TN","DGPTS PQ",72,0)  ;   for th e <701> PT F record:   AO, IR, E C, MST, NT R, CLV"RTN ","DGPTSPQ ",73,0) ;    Process:  Check if  the desire d indicato r was answ ered on a  <501>."RTN ","DGPTSPQ ",74,0) ;    changed  6/17/98 fo r MST enha ncement"RT N","DGPTSP Q",75,0) ;    INPUT D GFLAG - 1= AO, 2=IR,  3=EC, 4=MS T, 5=NTR,  6=CV, 7=SH AD, 8=CLV" RTN","DGPT SPQ",76,0)  N I"RTN", "DGPTSPQ", 77,0) S DG ER=1"RTN", "DGPTSPQ", 78,0) ;--  loop thru  <501>'s fo r indicato r specifie d by DGFLA G"RTN","DG PTSPQ",79, 0) S I=0 F   S I=$O(^ DGPT(DA,"M ",I)) Q:'I   I $P($G( ^DGPT(DA," M",I,0)),U ,DGFLAG+25 )'="" S DG ER=0 Q"RTN ","DGPTSPQ ",80,0) Q" RTN","DGPT SPQ",81,0)  ;"RTN","D GPTSPQ",82 ,0)UP701 ; -- This fu nction wil l loop thr u the <501 > and dete rmine if a ny"RTN","D GPTSPQ",83 ,0) ;   of  the SC, A O, IR, EC,  MST, NTR,  CV, SHAD  and CLV qu estions ha ve been"RT N","DGPTSP Q",84,0) ;    answere d.  If so,  the corre sponding < 701> will  be updated ."RTN","DG PTSPQ",85, 0) ;   An  answer of  "yes" will  take prec edence."RT N","DGPTSP Q",86,0) ; "RTN","DGP TSPQ",87,0 ) ;   INPU T : DGPTF" RTN","DGPT SPQ",88,0)  ;   chang ed 6/17/98  for MST e nhancement "RTN","DGP TSPQ",89,0 ) ;   RSD  2.6.5.1 Ca mp Lejeune  DG*5.3*91 4"RTN","DG PTSPQ",90, 0) N I,DGS C,DGAO,DGI R,DGEC,DGM OV,DGMST,D GNTR,DGCV, DGSHAD,DGC LV"RTN","D GPTSPQ",91 ,0) S (DGS C,DGAO,DGI R,DGEC,DGM ST,DGNTR,D GCV,DGSHAD ,DGCLV)="@ ""RTN","DG PTSPQ",92, 0) ;-- loo p thru <50 1>s"RTN"," DGPTSPQ",9 3,0) S I=0  F  S I=$O (^DGPT(DGP TF,"M",I))  Q:'I  S D GMOV=$G(^( I,0)) I DG MOV'="" D" RTN","DGPT SPQ",94,0)  .;-- sc"R TN","DGPTS PQ",95,0)  .I $P(DGMO V,U,18)'=" ",DGSC'=1  S DGSC=$P( DGMOV,U,18 )"RTN","DG PTSPQ",96, 0) .;-- ao "RTN","DGP TSPQ",97,0 ) .I $P(DG MOV,U,26)' ="",DGAO'= "Y" S DGAO =$P(DGMOV, U,26)"RTN" ,"DGPTSPQ" ,98,0) .;- - ir"RTN", "DGPTSPQ", 99,0) .I $ P(DGMOV,U, 27)'="",DG IR'="Y" S  DGIR=$P(DG MOV,U,27)" RTN","DGPT SPQ",100,0 ) .;-- ec" RTN","DGPT SPQ",101,0 ) .I $P(DG MOV,U,28)' ="",DGEC'= "Y" S DGEC =$P(DGMOV, U,28)"RTN" ,"DGPTSPQ" ,102,0) .; -- mst ;ad ded 6/17/9 8 for MST  enhancemen t"RTN","DG PTSPQ",103 ,0) .I $P( DGMOV,U,29 )'="",DGMS T'="Y" S D GMST=$P(DG MOV,U,29)" RTN","DGPT SPQ",104,0 ) .;-- ntr "RTN","DGP TSPQ",105, 0) .I $P(D GMOV,U,30) '="",DGNTR '="Y" S DG NTR=$P(DGM OV,U,30)"R TN","DGPTS PQ",106,0)  .;-- cv"R TN","DGPTS PQ",107,0)  .I $P(DGM OV,U,31)'= "",DGCV'=" Y" S DGCV= $P(DGMOV,U ,31)"RTN", "DGPTSPQ", 108,0) .;- - shad"RTN ","DGPTSPQ ",109,0) . I $P(DGMOV ,U,32)'="" ,DGSHAD'=" Y" S DGSHA D=$P(DGMOV ,U,32)"RTN ","DGPTSPQ ",110,0) . ;-- CLV ;R SD 2.6.5.1  Camp Leje une DG*5.3 *914 "RTN" ,"DGPTSPQ" ,111,0) .I  $P(DGMOV, U,33)'="", DGCLV'="Y"  S DGCLV=$ P(DGMOV,U, 33)"RTN"," DGPTSPQ",1 12,0) .;--  update <7 01> fields "RTN","DGP TSPQ",113, 0) .; chan ged 6/17/9 8 for MST  enhancemen t ; 12/27/ 17 Modifie d code to  prevent CL V value fr om deletin g at the 7 0 node lev el"RTN","D GPTSPQ",11 4,0) .S DR ="25////^S  X=DGSC;26 ////^S X=D GAO;27//// ^S X=DGIR; 28////^S X =DGEC;29// //^S X=DGM ST;30////^ S X=DGNTR; 31////^S X =DGCV;32// //^S X=DGS HAD;33//// ^S X=DGCLV ""RTN","DG PTSPQ",115 ,0) .S DIE ="^DGPT("_ DGPTF_","" M"",",DP=4 5.02,DA(1) =DGPTF,DA= I"RTN","DG PTSPQ",116 ,0) .D ^DI E"RTN","DG PTSPQ",117 ,0)UPQ Q"R TN","DGPTS PQ",118,0)  ;"RTN","D GPTUTL")0^ 57^B236201 17"RTN","D GPTUTL",1, 0)DGPTUTL  ;ALB/AS -  PTF UTILIT Y ROUTINE  ;8/14/03 1 1:35am"RTN ","DGPTUTL ",2,0) ;;5 .3;Registr ation;**26 ,114,234,4 66,544,850 ,914**;Aug  13, 1993; Build 104" RTN","DGPT UTL",3,0)D  I $L(Y)'< 7 S %=$E(Y ,4,5)*3,Y= $E("JANFEB MARAPRMAYJ UNJULAUGSE POCTNOVDEC ",%-2,%)_"  "_$S($E(Y ,6,7):$J(+ $E(Y,6,7), 2)_",",1:" ")_($E(Y,1 ,3)+1700)_ $S(Y[".":"  "_$E(Y_0, 9,10)_":"_ $E(Y_"000" ,11,12),1: "") Q"RTN" ,"DGPTUTL" ,4,0) S Y= "" Q"RTN", "DGPTUTL", 5,0)PM ;se ts variabl es from ^D GPM global "RTN","DGP TUTL",6,0)  S DGPMCA= $O(^DGPM(" APTF",PTF, 0)),DGPMAN =$S($D(^DG PM(+DGPMCA ,0)):^(0), 1:"") Q"RT N","DGPTUT L",7,0)MT  ;Determine  and store  Means Tes t Indicato r"RTN","DG PTUTL",8,0 ) ;-- get  eligibilit y code"RTN ","DGPTUTL ",9,0) S D GZEC=$P($G (^DGPT(PTF ,101)),U,8 ),DGZEC=$S ($D(^DIC(8 ,+DGZEC,0) ):^(0),1:" ") I $P(DG ZEC,U,5)=" N" S DGX=" N" G DIE"R TN","DGPTU TL",10,0)  ;-- admit  prior to 7 /1/86 is a n X"RTN"," DGPTUTL",1 1,0) I DGA DM<2860701  S DGX="X"  G DIE"RTN ","DGPTUTL ",12,0) ;- -"RTN","DG PTUTL",13, 0) I $D(^D GPT(PTF,10 1)),$D(^DI C(45.1,+^( 101),0)),$ P(^(0),"^" ,4) S DGX= "X" G DIE" RTN","DGPT UTL",14,0)  I $P(^DG( 43,1,0),U, 21),DGADM] "",$D(^DIC (42,+$P(DG PMAN,U,6), 0)),$P(^(0 ),U,3)="D"  S DGX="X"  G DIE"RTN ","DGPTUTL ",15,0) S  DGT=$P($G( ^DGPT(PTF, 70)),"."), DGZ1=$$LST ^DGMTU(DFN ,DGT) G AS :'DGZ1"RTN ","DGPTUTL ",16,0) ;- - sc < 50  %, %O non  comp, move ments are  sc"RTN","D GPTUTL",17 ,0) I $P(D GZEC,U,4)= 3,$$SC^DGM TR(DFN),$$ ANYSC^DGPT SCAN(PTF)  S DGX="AS"  G DIE"RTN ","DGPTUTL ",18,0) ;- - sc <50 % , %0 non-c omp, no mo vement sc,  mt =a"RTN ","DGPTUTL ",19,0) I  $P(DGZEC,U ,4)=3,$$SC ^DGMTR(DFN ),'$$ANYSC ^DGPTSCAN( PTF),$P(DG Z1,U,4)="A " S DGX="A N" G DIE"R TN","DGPTU TL",20,0)  ;-- sc, >0 %  - DG*5. 3*544"RTN" ,"DGPTUTL" ,21,0) I " ^1^3^"[("^ "_$P(DGZEC ,U,4)_"^") ,$P($G(^DP T(DFN,.3)) ,U,2)>0,$P (DGZ1,U,4) ="A" S DGX ="AS" G DI E"RTN","DG PTUTL",22, 0) ;"RTN", "DGPTUTL", 23,0) S DG X=$S('$D(D GZ1):"U",1 :$P(DGZ1,U ,4))"RTN", "DGPTUTL", 24,0) ; De termine if  the Pendi ng Adjudic ation is f or MT(C) G MT(G)"RTN" ,"DGPTUTL" ,25,0) I D GX="P" D   G DIE"RTN" ,"DGPTUTL" ,26,0) . I  '+$P($G(D GZ1),U) S  DGX="U" Q" RTN","DGPT UTL",27,0)  . S DGX=$ $PA^DGMTUT L($P(DGZ1, U)),DGX=$S ('$D(DGX): "U",DGX="M T":"C",DGX ="GMT":"G" ,1:"U")"RT N","DGPTUT L",28,0) S  DGX=$S(DG X="A":"AN" ,"BCGN"[DG X:DGX,1:"U ") G DIE:D GX'="N""RT N","DGPTUT L",29,0) ; -- AO or I R"RTN","DG PTUTL",30, 0)AS S DGZ =$S($D(^DP T(DFN,.321 )):^(.321) ,1:0) I $P (DGZ,U,2)= "Y"!($P(DG Z,U,3)="Y" ) S DGX="A S" G DIE"R TN","DGPTU TL",31,0)  ;-- EC"RTN ","DGPTUTL ",32,0) S  DGZ=$S($D( ^DPT(DFN,. 322)):^(.3 22),1:0) I  $P(DGZ,U, 13)="Y" S  DGX="AS" G  DIE"RTN", "DGPTUTL", 33,0) ;--  NTR"RTN"," DGPTUTL",3 4,0) N DGN TARR S DGZ =$S($$GETC UR^DGNTAPI (DFN,"DGNT ARR")>0:DG NTARR("NTR "),1:"") I  $P(DGZ,U) ="Y" S DGX ="AS" G DI E"RTN","DG PTUTL",35, 0) ;-- MST "RTN","DGP TUTL",36,0 ) S DGZ=$$ GETSTAT^DG MSTAPI(DFN ) I $P(DGZ ,U,2)="Y"  S DGX="AS"  G DIE"RTN ","DGPTUTL ",37,0) ;p wc RSD 2.6 .6.2.1  DG *5.3*914 C amp Lejeun e"RTN","DG PTUTL",38, 0) ;-- CL" RTN","DGPT UTL",39,0)  S DGZ=$S( $D(^DPT(DF N,.3217)): ^(.3217),1 :0) I $P(D GZ,U,1)="Y " S DGX="A S" G DIE"R TN","DGPTU TL",40,0)  ;-- if vet eran and A A or House bound"RTN" ,"DGPTUTL" ,41,0) I $ P(DGZEC,U, 5)="Y",$P( DGZEC,U,4) <4,"^2^15^ "'[(U_$P(D GZEC,U,9)_ U) S DGX=" AS" G DIE" RTN","DGPT UTL",42,0)  ;"RTN","D GPTUTL",43 ,0) I DGZE C]"" S DGX ="AN" G DI E"RTN","DG PTUTL",44, 0) ;"RTN", "DGPTUTL", 45,0) S DG X="U" I '$ D(DGLN) W  !,"===> th is patient  has a bla nk Eligibi lity Code" "RTN","DGP TUTL",46,0 ) ;"RTN"," DGPTUTL",4 7,0)DIE I  '$D(DGBGJ)  S DA=PTF, DR="10///" _DGX_$S('$ P(^DGPT(PT F,0),U,3): ";3///`"_$ P($$SITE^V ASITE,U),1 :""),DIE=" ^DGPT(" D  ^DIE K DGZ EC,DGZ,DGZ 1,DG1,DGX, DR,DGT,DA, DIE Q"RTN" ,"DGPTUTL" ,48,0) I D GX'=$P(^DG PT(PTF,0), "^",10) S  DA=PTF,DR= "10///"_DG X,DIE="^DG PT(" D ^DI E"RTN","DG PTUTL",49, 0) K DGZEC ,DGZ,DGZ1, DG1,DGX,DG T,DR,DA,DI E Q"RTN"," DGPTUTL",5 0,0) ;"RTN ","DGPTUTL ",51,0)RTY  ; -- set  rec type v ariables"R TN","DGPTU TL",52,0)  ;  input:       Y :=  rec type # "RTN","DGP TUTL",53,0 ) ; output :  DGRTY : = rec type  #"RTN","D GPTUTL",54 ,0) ;          DGRTY0  := name o f type (in  future, m ay expand  to 0th nod e)"RTN","D GPTUTL",55 ,0) ;"RTN" ,"DGPTUTL" ,56,0) I Y =1 S DGRTY =1,DGRTY0= "PTF""RTN" ,"DGPTUTL" ,57,0) I Y =2 S DGRTY =2,DGRTY0= "CENSUS""R TN","DGPTU TL",58,0)  Q"RTN","DG PTUTL",59, 0) ;"RTN", "DGPTUTL", 60,0)HANG  ;"RTN","DG PTUTL",61, 0) R DGPTH ANG:4 K DG PTHANG Q"R TN","DGPTU TL",62,0)  ;"RTN","DG PTUTL",63, 0)CEN ; --  find curr ent active  census ;  return ifn  and 0th n ode"RTN"," DGPTUTL",6 4,0) S DGC N=$O(^DG(4 5.86,"AC", 1,0)),DGCN 0=$S($D(^D G(45.86,+D GCN,0)):^( 0),1:"")"R TN","DGPTU TL",65,0)  Q"RTN","DG PTUTL",66, 0) ;"RTN", "DGPTUTL", 67,0)FMT ;  -- determ ine PTF re cord forma t"RTN","DG PTUTL",68, 0) ;"RTN", "DGPTUTL", 69,0) N IM PDATE,EFFD ATE,DGPTDA T"RTN","DG PTUTL",70, 0) S Z=$S( $G(Y):Y,1: DT)"RTN"," DGPTUTL",7 1,0) S DGP TFMT=1 D F DT"RTN","D GPTUTL",72 ,0) I Z>Y  S DGPTFMT= 2"RTN","DG PTUTL",73, 0) D EFFDA TE^DGPTIC1 0($G(PTF)) "RTN","DGP TUTL",74,0 ) Q:IMPDAT E'?7N"RTN" ,"DGPTUTL" ,75,0) I Z '<IMPDATE  S DGPTFMT= 3 ;(ICD-10 )"RTN","DG PTUTL",76, 0) K Z"RTN ","DGPTUTL ",77,0) Q" RTN","DGPT UTL",78,0)  ;"RTN","D GPTUTL",79 ,0)FDT ; - - set new  format dat e for test ing"RTN"," DGPTUTL",8 0,0) S Y=2 901000 Q"R TN","DGPTU TL",81,0)  ;"RTN","DG PTUTL",82, 0)UPDT ; - - update P TF record  w/PTF and  DFN define d"RTN","DG PTUTL",83, 0) I '$D(^ DGPT(PTF,0 )) W:'$D(Z TQUEUED) ! !,*7,">>>  PTF record  #",PTF,"  does not e xist." G U PDTQ"RTN", "DGPTUTL", 84,0) S X= ^(0)"RTN", "DGPTUTL", 85,0) I $P (X,U,11)>1  W:'$D(ZTQ UEUED) !!, *7,">>> Re cord #",PT F," is not  a PTF rec ord." G UP DTQ"RTN"," DGPTUTL",8 6,0) S DGP TFE=$P(X,U ,4),(DGADM ,AD)=+$P(X ,U,2),DGST =$D(^DGP(4 5.84,PTF)) >0"RTN","D GPTUTL",87 ,0) I DGST  W:'$D(ZTQ UEUED) !!, *7,">>> PT F record # ",PTF," is  closed ou t. No upda ting allow ed." G UPD TQ"RTN","D GPTUTL",88 ,0) I DGPT FE W:'$D(Z TQUEUED) ! !,*7,">>>  PTF record  #",PTF,"  is a fee P TF record.  No updati ng is poss ible." G U PDTQ"RTN", "DGPTUTL", 89,0) N DG PMCA,DGPMA N D PM"RTN ","DGPTUTL ",90,0) I  DGPMCA D:' $P(^DGPT(P TF,0),U,5)  SUF^DGPTF  D LE^DGPT TS,DC^DGPT F"RTN","DG PTUTL",91, 0) ;"RTN", "DGPTUTL", 92,0)UPDTQ  K AGE,D0, D1,DA,DGAD M,DGLAST,D GP,DGTY,DI C,DIE,DR,D IV,DIU,DIS YS,DIK,DIK LM,DIG,DIH ,DI,DIW,DI WL,DIWR,DI WT,DN,DOB, DQ,DG,DRG, SEX,TY,L,P 1,DIS2,DGP TFE,DGST,D GX,DFN1,DF N2,PR,I1,T DD,AD"RTN" ,"DGPTUTL" ,93,0) Q"R TN","DGPTU TL",94,0)  ;"RTN","DG PTUTL",95, 0)EXPL ; - - explode  string A(i nput) to D GA(output) "RTN","DGP TUTL",96,0 ) N J,L S  DGA=$E(A,2 ,999)"RTN" ,"DGPTUTL" ,97,0) I D GA["-" S X =DGA,DGA=" " F J=1:1  S L=$P(X," ,",J) Q:'L   D EXPL1: L["-" S:L] "" DGA=DGA _L_"," Q:$ P(X,",",J+ 1,999)=""" RTN","DGPT UTL",98,0)  Q"RTN","D GPTUTL",99 ,0) ;"RTN" ,"DGPTUTL" ,100,0)EXP L1 ; -- ex plode stri ng 'L' of  form "1-12 " ; input  and output  is 'L'"RT N","DGPTUT L",101,0)  N I,X"RTN" ,"DGPTUTL" ,102,0) I  $P(L,"-")' ?1N.N!($P( L,"-",2,99 9)'?1N.N)  S L="" G E XPL1Q"RTN" ,"DGPTUTL" ,103,0) I  +L>$P(L,"- ",2) S L=" " G EXPL1Q "RTN","DGP TUTL",104, 0) I +L=+$ P(L,"-",2)  S L=+L G  EXPL1Q"RTN ","DGPTUTL ",105,0) S  X="" F I= +L:1:+$P(L ,"-",2) Q: ($L(X)+$L( I)+1)>240   S X=X_I_" ,""RTN","D GPTUTL",10 6,0) S L=$ E(X,1,$L(X )-1)"RTN", "DGPTUTL", 107,0)EXPL 1Q Q"RTN", "DGPTUTL", 108,0) ;"R TN","DGPTU TL",109,0) CKPOS(ADEL ,DEFAULT)  ;-- This f unction wi ll check t he admitti ng eligibi lity"RTN", "DGPTUTL", 110,0) ; a nd the POS  to make s ure for No n-Vet elig ibilities  that a"RTN ","DGPTUTL ",111,0) ;  9 - Other  or None P OS is pres ent."RTN", "DGPTUTL", 112,0) ;"R TN","DGPTU TL",113,0)  ;  INPUT  - ADEL : A dmitting E ligibility  (Pointer  to file 8) "RTN","DGP TUTL",114, 0) ;        DEFAULT :  Default P OS (option al) (Point er to file  21)"RTN", "DGPTUTL", 115,0) ;   OUTPUT- PO S : POS Co de. 0 - Er ror"RTN"," DGPTUTL",1 16,0) ;"RT N","DGPTUT L",117,0)  N RESULT,X ,Y"RTN","D GPTUTL",11 8,0) ;If D FN is not  needed her e, kill DF N to avoid  VADPT err or out."RT N","DGPTUT L",119,0)  I $G(DFN)= "" N DFN S  DFN=$G(DG SDFN) I $G (DFN)="" K  DFN"RTN", "DGPTUTL", 120,0) D E LIG^VADPT" RTN","DGPT UTL",121,0 ) I $D(VAE L(1))=1 S  RESULT=$G( DEFAULT) G  CKPOSQ"RT N","DGPTUT L",122,0)  S RESULT=0 ,Y=$G(DEFA ULT)"RTN", "DGPTUTL", 123,0) I ' $D(^DIC(8, +ADEL,0))  G CKPOSQ"R TN","DGPTU TL",124,0)  S X=$G(^D IC(8.1,$P( $G(^DIC(8, +ADEL,0)), U,9),0))"R TN","DGPTU TL",125,0)  ;-- if no n vet set  POS to Oth er"RTN","D GPTUTL",12 6,0) I $P( X,U,5)="N"  S RESULT= 9"RTN","DG PTUTL",127 ,0) ;-- if  vet then  use defaul t"RTN","DG PTUTL",128 ,0) I $P(X ,U,5)="Y", Y'="" S RE SULT=Y"RTN ","DGPTUTL ",129,0)CK POSQ ;"RTN ","DGPTUTL ",130,0) Q  RESULT"RT N","DGPTUT L",131,0)  ;"RTN","DG RPDB")0^35 ^B24240129 "RTN","DGR PDB",1,0)D GRPDB ;ALB /AAS,JAN,E RC,PHH - V IEW ONLY S CREEN TO D ETERMINE B ILLING ELI GIBILITY ; 3/23/06 8: 16am"RTN", "DGRPDB",2 ,0) ;;5.3; Registrati on;**26,50 ,358,570,6 31,709,713 ,749,914** ;Aug 13, 1 993;Build  104"RTN"," DGRPDB",3, 0) ;"RTN", "DGRPDB",4 ,0)% S:'$D (DGQUIT) D GQUIT=0"RT N","DGRPDB ",5,0) G:D GQUIT END  S DIC="^DP T(",DIC(0) ="AEQMN" D  ^DIC G:+Y <1 END S D FN=+Y D EN "RTN","DGR PDB",6,0)  G %"RTN"," DGRPDB",7, 0) ;"RTN", "DGRPDB",8 ,0)EN ;ent ry with DF N defined. "RTN","DGR PDB",9,0)  Q:'$D(DFN)   D HOME^% ZIS,2^VADP T,HDR"RTN" ,"DGRPDB", 10,0) D MT ,AOIR,ELIG ,DIS"RTN", "DGRPDB",1 1,0) N DGI NS"RTN","D GRPDB",12, 0) I $$INS UR^IBBAPI( DFN,"","AR ",.DGINS,1 )"RTN","DG RPDB",13,0 ) S C="",C =$O(DGINS( "IBBAPI"," INSUR",C), -1),C=+C+6 "RTN","DGR PDB",14,0)  D:($Y>(IO SL-C)) PAU SE,HDR:'DG QUIT Q:DGQ UIT  D INS ,PAUSE"RTN ","DGRPDB" ,15,0) Q"R TN","DGRPD B",16,0) ; "RTN","DGR PDB",17,0) ELIG ;elig ibility co de(s)"RTN" ,"DGRPDB", 18,0) W !! ," Primary  Elig. Cod e: ",$P(VA EL(1),"^", 2),"  --   ",$S(VAEL( 8)']"":"NO T VERIFIED ",1:$P(VAE L(8),"^",2 ))"RTN","D GRPDB",19, 0) I VAEL( 8)]"" S Y= $S($D(^DPT (DFN,.361) ):$P(^(.36 1),"^",2), 1:"") W "   " D DT^DI Q"RTN","DG RPDB",20,0 ) W !,"Oth er Elig. C ode(s): "  I $D(VAEL( 1))>9 S I1 =0 F I=0:0  S I=$O(VA EL(1,I)) Q :'I  S I1= I1+1 W:I1> 1 !?21 W $ P(VAEL(1,I ),"^",2)"R TN","DGRPD B",21,0) E   W "NO AD DITIONAL E LIGIBILITI ES IDENTIF IED""RTN", "DGRPDB",2 2,0) Q"RTN ","DGRPDB" ,23,0) ;"R TN","DGRPD B",24,0)DI S ;rated d isabilitie s - Integr ation Agre ement #700 "RTN","DGR PDB",25,0)  ;"RTN","D GRPDB",26, 0) ;  This  is called  from the  FEE and MC CR package !!!"RTN"," DGRPDB",27 ,0) ;"RTN" ,"DGRPDB", 28,0) ;  I nput:  DFN  as IEN of  PATIENT f ile"RTN"," DGRPDB",29 ,0) ;           VAEL  array (if  no passed,  it is set ) of eligi bility inf o"RTN","DG RPDB",30,0 ) ;"RTN"," DGRPDB",31 ,0) I '$D( VAEL) D EL IG^VADPT S  DGKVAR=1" RTN","DGRP DB",32,0)  W:'+VAEL(3 ) !!,"  Se rvice Conn ected: NO"  W:+VAEL(3 ) !!,"          SC Pe rcent: ",$ P(VAEL(3), "^",2)_"%" "RTN","DGR PDB",33,0)  N DGQUIT" RTN","DGRP DB",34,0)  W !," Rate d Disabili ties: " I  'VAEL(4),$ S('$D(^DG( 391,+VAEL( 6),0)):1,$ P(^(0),"^" ,2):0,1:1)  W "NOT A  VETERAN" G  DISQ"RTN" ,"DGRPDB", 35,0) S I3 =0 F I=0:0  S I=$O(^D PT(DFN,.37 2,I)) Q:'I !($G(DGQUI T)=1)  D"R TN","DGRPD B",36,0) .  S I1=^(I, 0),I2=$S($ D(^DIC(31, +I1,0)):$P (^(0),"^", 1)_" ("_+$ P(I1,"^",2 )_"%-"_$S( $P(I1,"^", 3):"SC",$P (I1,"^",3) ']"":"not  specified" ,1:"NSC")_ ")",1:""), I3=I3+1"RT N","DGRPDB ",37,0) .  I $Y>(IOSL -3) D PAUS E I $G(DGQ UIT)=0 W @ IOF"RTN"," DGRPDB",38 ,0) . I $G (DGQUIT)=1  Q"RTN","D GRPDB",39, 0) . W:I3> 1 !?21 W I 2"RTN","DG RPDB",40,0 ) W:'I3 "N ONE STATED ""RTN","DG RPDB",41,0 )DISQ I $D (DGKVAR) D  KVAR^VADP T K DGKVAR "RTN","DGR PDB",42,0)  K I,I1,I2 ,I3"RTN"," DGRPDB",43 ,0) Q"RTN" ,"DGRPDB", 44,0) ;"RT N","DGRPDB ",45,0)INS  ;insuranc e informat ion"RTN"," DGRPDB",46 ,0) ;"RTN" ,"DGRPDB", 47,0) ;  T his is cal led form t he FEE pac kage!!!"RT N","DGRPDB ",48,0) ;" RTN","DGRP DB",49,0)  ;  Input:   DFN as IE N of PATIE NT file"RT N","DGRPDB ",50,0) ;           D GINSDT as  date to co mpute insu rance flag  as of (de fault DT)" RTN","DGRP DB",51,0)  ;"RTN","DG RPDB",52,0 ) Q:'$D(DF N)"RTN","D GRPDB",53, 0) W !!,"     Health  Insurance:  ""RTN","D GRPDB",54, 0) S Z=$$I NSUR^IBBAP I(DFN,$S($ D(DGINSDT) :DGINSDT,1 :DT))"RTN" ,"DGRPDB", 55,0) W $S (Z:"YES",1 :"NO")"RTN ","DGRPDB" ,56,0) D D ISP^DGIBDS P"RTN","DG RPDB",57,0 )INSQ K I, I1,DGX,Z"R TN","DGRPD B",58,0) Q "RTN","DGR PDB",59,0)  ;"RTN","D GRPDB",60, 0)IN ; Old  code"RTN" ,"DGRPDB", 61,0) Q"RT N","DGRPDB ",62,0) ;" RTN","DGRP DB",63,0)A OIR ;Agent  Orange/io nizing rad iation/Cam p Lejeune" RTN","DGRP DB",64,0)  N DGEC,NTA ,DGCL"RTN" ,"DGRPDB", 65,0) S DG X=$S($D(^D PT(DFN,.32 1)):^(.321 ),1:"")"RT N","DGRPDB ",66,0) F  I=2,3 S X= $P(DGX,"^" ,I) W:I=2  !,"            A/O Ex p.: " W:I= 3 "ION Rad .: " W $S( X="Y":"YES ",X="N":"N O",X="U":" UNKNOWN",1 :"NOT ANSW ERED"),"    ""RTN","D GRPDB",67, 0) S X=$G( ^DPT(DFN,. 38)),X1=$P (X,"^",1)  W "Medicai d Elig: ", $S(X1="":" NOT ANSWER ED",'X1:"N O",1:"YES" ) I ($X+15 )'>IOM W "  - " S Y=$ P(X,"^",2)  D D^DIQ W  $P(Y,"@") "RTN","DGR PDB",68,0)  S DGEC=$S ($D(^DPT(D FN,.322)): ^DPT(DFN,. 322),1:"") "RTN","DGR PDB",69,0)  S X=$P(DG EC,U,13) W  !,"         Env Cont am.: " W $ S(X="Y":"Y ES",X="N": "NO",X="U" :"UNKNOWN" ,1:"NOT AN SWERED"),"    ""RTN", "DGRPDB",7 0,0) S NTA =$S($$GETC UR^DGNTAPI (DFN,"DGNT ARR")>0:DG NTARR("INT RP"),1:"") "RTN","DGR PDB",71,0)  K DGNTARR "RTN","DGR PDB",72,0)  W "N/T Ra dium: " W  $S(NTA'="" :NTA,1:"NO T ANSWERED ")"RTN","D GRPDB",73, 0) ;PWC DG *5.3*914 R SD - 2.6.1 9 Camp Lej eune will  always be  on next li ne"RTN","D GRPDB",74, 0) S DGCL= $S($D(^DPT (DFN,.3217 )):^DPT(DF N,.3217),1 :""),X=$P( DGCL,"^",1 ) W !,"        Camp L ejeune: "  W $S(X="Y" :"YES",X=" N":"NO",1: "NOT ANSWE RED")"RTN" ,"DGRPDB", 75,0) Q"RT N","DGRPDB ",76,0) ;" RTN","DGRP DB",77,0)P AUSE F J=1 :1 Q:($Y>( IOSL-3))   W !"RTN"," DGRPDB",78 ,0) S DGX1 ="" I $E(I OST,1,2)[" C-" N DIR  S DIR(0)=" E" D ^DIR  S DGQUIT=' Y"RTN","DG RPDB",79,0 ) Q"RTN"," DGRPDB",80 ,0) ;"RTN" ,"DGRPDB", 81,0)HDR ; Screen Hea der"RTN"," DGRPDB",82 ,0) W @IOF  I $P(VAEL (6),"^",2) ]"" S DGTY PE=$P(VAEL (6),"^",2) "RTN","DGR PDB",83,0)  W $P(VADM (1),"^",1) ,?32,VA("P ID"),?47,$ P(VADM(3), "^",2) S X =$S($D(DGT YPE):$P(DG TYPE,"^",1 ),1:"PATIE NT TYPE UN KNOWN"),X1 =79-$L(X)  W ?X1,X"RT N","DGRPDB ",84,0) S  X="",$P(X, "=",80)=""  W !,X Q"R TN","DGRPD B",85,0) Q "RTN","DGR PDB",86,0)  ;"RTN","D GRPDB",87, 0)MT I '$O (^DGMT(408 .31,"AD",1 ,DFN,0)) W  !,"  Mean s Test Sta tus:  NOT  IN MEANS T EST FILE"  Q"RTN","DG RPDB",88,0 ) ;if pati ent is on  a DOM ward , don't di splay Mean s Test req uired mess age"RTN"," DGRPDB",89 ,0) D DOM^ DGMTR D:'$ G(DGDOM) D IS^DGMTU(D FN) K DGDO M"RTN","DG RPDB",90,0 ) Q"RTN"," DGRPDB",91 ,0) ;"RTN" ,"DGRPDB", 92,0)END D  KVAR^VADP T"RTN","DG RPDB",93,0 ) K A,C,I, I1,I2,I3,J ,DIC,DIR,D FN,DGA1,DG MT,DGMTL,D GMTLA,DGX, DGX1,DGT,D GTYPE,DGQU IT,DGMTLL, X,X1,VAROO T,VA,Y,Z"R TN","DGRPD B",94,0) Q "RTN","DGR PDB",95,0)  ;"RTN","D GRPDB",96, 0)RDIS(DGD FN,DGARR)  ;API to re turn all R ated Disab ilities fr om the "RT N","DGRPDB ",97,0) ;P atient fil e for a pa tient usin g an array .  Returne d in desce nding Serv ice Connec ted percen t."RTN","D GRPDB",98, 0) ;"RTN", "DGRPDB",9 9,0) ; Int egration A greement # 4807"RTN", "DGRPDB",1 00,0) ; "R TN","DGRPD B",101,0)  ;Input           DGDF N - IEN of  patient f ile (requi red)"RTN", "DGRPDB",1 02,0) ;Inp ut/Output    DGARR -  name of ar ray for re turned dis ability in fo (requir ed)"RTN"," DGRPDB",10 3,0) ;                 piece 1 -  Disabilit y IEN (in  file 31)"R TN","DGRPD B",104,0)  ;                piec e 2 - Disa bility %"R TN","DGRPD B",105,0)  ;                piec e 3 - SC?  (1,0)"RTN" ,"DGRPDB", 106,0) ;                 piece 4  - extremi ty affecte d"RTN","DG RPDB",107, 0) ;                p iece 5 - o riginal ef fective da te"RTN","D GRPDB",108 ,0) ;                 piece 6 -  current ef fective da te"RTN","D GRPDB",109 ,0) ;Outpu t 1=succes sful and a rray retur ned with d ata"RTN"," DGRPDB",11 0,0) ;        0=unsuc cessful an d no array "RTN","DGR PDB",111,0 ) ;          "RTN","D GRPDB",112 ,0) N DGAR R1,DGC,DGC C,DGERR,DG NODE,DGCT, DGE,DGEE"R TN","DGRPD B",113,0)  K DGW,DGAR R"RTN","DG RPDB",114, 0) I $G(DG DFN)']"" Q  0"RTN","D GRPDB",115 ,0) I '$D( ^DPT(DGDFN ,0)) Q 0"R TN","DGRPD B",116,0)  D GETS^DIQ (2,DGDFN," .3721*","I ","DGARR1" ,"DGERR")" RTN","DGRP DB",117,0)  I $D(DGER R) Q 0"RTN ","DGRPDB" ,118,0) S  DGCC=0"RTN ","DGRPDB" ,119,0) S  DGCC=$O(^D PT(DGDFN,. 372,DGCC)) "RTN","DGR PDB",120,0 ) I 'DGCC  Q 0"RTN"," DGRPDB",12 1,0) S DGC ="""RTN"," DGRPDB",12 2,0) F  S  DGC=$O(DGA RR1(2.04,D GC)) Q:DGC ']""  D"RT N","DGRPDB ",123,0) .  S DGNODE= DGC"RTN"," DGRPDB",12 4,0) . S D GARR(DGC)= DGARR1(2.0 4,DGNODE,. 01,"I")_"^ "_DGARR1(2 .04,DGNODE ,2,"I")_"^ "_DGARR1(2 .04,DGNODE ,3,"I")_"^ "_DGARR1(2 .04,DGNODE ,4,"I")_"^ "_DGARR1(2 .04,DGNODE ,5,"I")_"^ "_DGARR1(2 .04,DGNODE ,6,"I")"RT N","DGRPDB ",125,0) S  DGE="""RT N","DGRPDB ",126,0) F   S DGE=$O (DGARR(DGE )) Q:'DGE   D"RTN","D GRPDB",127 ,0) . I $P (DGARR(DGE ),U,2)=""  S $P(DGARR (DGE),U,2) =0"RTN","D GRPDB",128 ,0) . S DG W($P(DGARR (DGE),U,2) ,$P(DGE,", ",1))=DGAR R(DGE)"RTN ","DGRPDB" ,129,0) S  DGE="",DGC T=1"RTN"," DGRPDB",13 0,0) K DGA RR"RTN","D GRPDB",131 ,0) F  S D GE=$O(DGW( DGE),-1) Q :DGE']""   D"RTN","DG RPDB",132, 0) . F DGE E=0:0 S DG EE=$O(DGW( DGE,DGEE))  Q:DGEE'>0   D"RTN"," DGRPDB",13 3,0) . . S  DGARR(DGC T)=DGW(DGE ,DGEE) S D GCT=DGCT+1 "RTN","DGR PDB",134,0 ) K DGW"RT N","DGRPDB ",135,0) Q  1"RTN","D GRPDB",136 ,0) ;"RTN" ,"DGUTL3") 0^64^B1059 5349"RTN", "DGUTL3",1 ,0)DGUTL3  ;ALB/MTC,C KN - ELIGI BILITY UTI LITIES ;10 /4/05 12:2 2pm"RTN"," DGUTL3",2, 0) ;;5.3;R egistratio n;**114,50 6,653,914* *;Aug 13,  1993;Build  104"RTN", "DGUTL3",3 ,0) ;"RTN" ,"DGUTL3", 4,0) Q"RTN ","DGUTL3" ,5,0)ELIG( DFN,SOURCE ,DEFAULT)  ;-- This f unction wi ll prompt  for the el igibility  for a pati ent. If"RT N","DGUTL3 ",6,0) ;    only one  eligibilit y then it  will be re turned wit hout promp ting."RTN" ,"DGUTL3", 7,0) ;"RTN ","DGUTL3" ,8,0) ;    INPUT:  DF N - Patien t"RTN","DG UTL3",9,0)  ;            SOURCE  - (1:PTF,2 :ADMISSION ,3:TRANSFE R)"RTN","D GUTL3",10, 0) ;            DEFAL UT - IEN f rom file 8 .1"RTN","D GUTL3",11, 0) ;  OUTP UT:  IEN o f file 8^N ame"RTN"," DGUTL3",12 ,0) ;"RTN" ,"DGUTL3", 13,0) ;"RT N","DGUTL3 ",14,0) N  RESULT,VAE L,ALLEL,EM P,X,DGDEF, Y"RTN","DG UTL3",15,0 ) ;"RTN"," DGUTL3",16 ,0) ;-- ge t eligibil ity codes" RTN","DGUT L3",17,0)  D GETEL(DF N)"RTN","D GUTL3",18, 0) S DGDEF =$P($G(^DI C(8,+$G(DE FAULT),0)) ,U)"RTN"," DGUTL3",19 ,0) I DGDE F'="" S DG DEF=DEFAUL T_U_DGDEF" RTN","DGUT L3",20,0)  ;"RTN","DG UTL3",21,0 ) S RESULT ="",EMP=$P (VAEL(1),U ,2),ALLEL= U_EMP"RTN" ,"DGUTL3", 22,0) I '$ D(VAEL) G  ELIGQ"RTN" ,"DGUTL3", 23,0) I $D (VAEL(1))= 1 S RESULT =VAEL(1) G  ELIGQ"RTN ","DGUTL3" ,24,0) ;--  if no def ault set d efault to  primary el igibility" RTN","DGUT L3",25,0)  I DGDEF=""  S DGDEF=V AEL(1)"RTN ","DGUTL3" ,26,0) ;"R TN","DGUTL 3",27,0)DI SP ;-- dis play choic es"RTN","D GUTL3",28, 0) W !,"TH IS PATIENT  HAS OTHER  ENTITLED  ELIGIBILIT IES:""RTN" ,"DGUTL3", 29,0) W !? 5,$P(VAEL( 1),U,2)"RT N","DGUTL3 ",30,0) S  X="" F  S  X=$O(VAEL( 1,X)) Q:X' >0  D"RTN" ,"DGUTL3", 31,0) . W  !?5,$P(VAE L(1,X),U,2 )"RTN","DG UTL3",32,0 ) . S ALLE L=ALLEL_U_ $P(VAEL(1, X),U,2)"RT N","DGUTL3 ",33,0) ;" RTN","DGUT L3",34,0)  ;-- prompt  for eligi bility cod es"RTN","D GUTL3",35, 0) ;"RTN", "DGUTL3",3 6,0)1 W !, "ENTER THE  ELIGIBILI TY FOR THI S "_$S(SOU RCE=1:"MOV EMENT",SOU RCE=2:"ADM ISSION",SO URCE=3:"TR ANSFER",1: "PATIENT") _": "_$P(D GDEF,U,2)_ "// ""RTN" ,"DGUTL3", 37,0) R X: DTIME"RTN" ,"DGUTL3", 38,0) ;--  if timeout "RTN","DGU TL3",39,0)  G ELIGQ:' $T"RTN","D GUTL3",40, 0) ;-- if  ^"RTN","DG UTL3",41,0 ) G ELIGQ: X[U"RTN"," DGUTL3",42 ,0) ;-- if  default ( primary) q uit"RTN"," DGUTL3",43 ,0) I X=""  S RESULT= DGDEF G EL IGQ"RTN"," DGUTL3",44 ,0) ;-- fi nd eligibi lity"RTN", "DGUTL3",4 5,0) S X=$ $UPPER^VAL M1(X)"RTN" ,"DGUTL3", 46,0) G DI SP:X["?",1 :ALLEL'[(U _X)"RTN"," DGUTL3",47 ,0) ;"RTN" ,"DGUTL3", 48,0) S EM P=X_$P($P( ALLEL,U_X, 2),U) W $P ($P(ALLEL, U_X,2),U)" RTN","DGUT L3",49,0)  I $P(VAEL( 1),U,2)=EM P S RESULT =VAEL(1) G  ELIGQ"RTN ","DGUTL3" ,50,0) S X ="" F  S X =$O(VAEL(1 ,X)) Q:X'> 0  D"RTN", "DGUTL3",5 1,0) . I $ P(VAEL(1,X ),U,2)=EMP  S RESULT= X_U_EMP"RT N","DGUTL3 ",52,0) ;" RTN","DGUT L3",53,0)E LIGQ ;"RTN ","DGUTL3" ,54,0) K V AEL"RTN"," DGUTL3",55 ,0) Q +RES ULT"RTN"," DGUTL3",56 ,0) ;"RTN" ,"DGUTL3", 57,0)GETEL (DFN) ;--  This funct ion will g et the eli gibilities  for the p atient"RTN ","DGUTL3" ,58,0) ;   specified  by DFN and  return al l the acti ve eligibi lities in  the"RTN"," DGUTL3",59 ,0) ;  ARR AY specifi ed."RTN"," DGUTL3",60 ,0) ;"RTN" ,"DGUTL3", 61,0) ;  I NPUT:  DFN  - Patient "RTN","DGU TL3",62,0)  ;"RTN","D GUTL3",63, 0) D ELIG^ VADPT"RTN" ,"DGUTL3", 64,0) Q"RT N","DGUTL3 ",65,0) ;" RTN","DGUT L3",66,0)G ETDEL(DFN, START,END)  ;-- This  function w ill scan t he Eligibi lity Date" RTN","DGUT L3",67,0)  ; Sensitiv e file #8. 3 for all  active eli gibilities  for a dat e range."R TN","DGUTL 3",68,0) ; "RTN","DGU TL3",69,0)  N DGI,DGJ ,DGK"RTN", "DGUTL3",7 0,0) ;"RTN ","DGUTL3" ,71,0) S D GI=0 F  S  DGI=$O(^VA EL(8.3,"AE ",DFN,DGI) ) Q:DGI=""   D"RTN"," DGUTL3",72 ,0) . S DG J=$O(^VAEL (8.3,"AE", DFN,DGI,0) ),DGK=^(DG J)"RTN","D GUTL3",73, 0) . I $P( DGK,U,2) S  VAEL(1)=D GI_U_$P($G (^DIC(8,DG I,0)),U)"R TN","DGUTL 3",74,0) .  I '$P(DGK ,U,2) S VA EL(1,DGI)= DGI_U_$P($ G(^DIC(8,D GI,0)),U)" RTN","DGUT L3",75,0)  Q"RTN","DG UTL3",76,0 ) ;"RTN"," DGUTL3",77 ,0)ASKPR(D FN) ;-- Th is functio n will ask  the user  for the pr imary elig ibility."R TN","DGUTL 3",78,0) ; "RTN","DGU TL3",79,0)  N RESULT, VAEL,ALLEL ,EMP,X,DGD EF,Y"RTN", "DGUTL3",8 0,0) ;"RTN ","DGUTL3" ,81,0) ;--  get eligi bility cod es"RTN","D GUTL3",82, 0) S DEFAU LT=$O(^VAE L(8.3,"AP" ,DFN,0))"R TN","DGUTL 3",83,0) S  DGDEF=$P( $G(^DIC(8, +$G(DEFAUL T),0)),U)" RTN","DGUT L3",84,0)  I DGDEF'=" " S DGDEF= DEFAULT_U_ DGDEF"RTN" ,"DGUTL3", 85,0) ;"RT N","DGUTL3 ",86,0) S  RESULT=""" RTN","DGUT L3",87,0)  ;"RTN","DG UTL3",88,0 )TRY W !," PRIMARY EL IGIBILITY  CODE: "_$P (DGDEF,U,2 )_"// ""RT N","DGUTL3 ",89,0) R  X:DTIME"RT N","DGUTL3 ",90,0) ;- - if timeo ut"RTN","D GUTL3",91, 0) G PRIMQ :'$T"RTN", "DGUTL3",9 2,0) ;-- i f ^"RTN"," DGUTL3",93 ,0) G PRIM Q:X[U"RTN" ,"DGUTL3", 94,0) ;--  find eligi bility"RTN ","DGUTL3" ,95,0) S X =$$UPPER^V ALM1(X)"RT N","DGUTL3 ",96,0) ;" RTN","DGUT L3",97,0)P RIMQ ;"RTN ","DGUTL3" ,98,0) K V AEL"RTN"," DGUTL3",99 ,0) Q +RES ULT"RTN"," DGUTL3",10 0,0) ;"RTN ","DGUTL3" ,101,0)BAD ADR(DFN) ; does this  patient ha ve a bad a ddress?"RT N","DGUTL3 ",102,0) ; "RTN","DGU TL3",103,0 ) Q:'$G(DF N) """RTN" ,"DGUTL3", 104,0) Q $ P($G(^DPT( DFN,.11)), "^",16)"RT N","DGUTL3 ",105,0) ; "RTN","DGU TL3",106,0 )DELBAI(DF N) ;delete  bad addre ss indicat or"RTN","D GUTL3",107 ,0) N FDA, IENS"RTN", "DGUTL3",1 08,0) Q:'$ G(DFN)"RTN ","DGUTL3" ,109,0) S  IENS=DFN_" ,",FDA(2,I ENS,.121)= "@""RTN"," DGUTL3",11 0,0) D FIL E^DIE("E", "FDA")"RTN ","DGUTL3" ,111,0) Q" RTN","DGUT L3",112,0) GETSHAD(DF N) ;Get cu rrent valu e of Proj  112/SHAD f rom Patien t file."RT N","DGUTL3 ",113,0) ;    Input:   DFN - Pat ient ien"R TN","DGUTL 3",114,0)  ;  Output:  Valid val ues - 1 (Y es), 0 (No ), or null "RTN","DGU TL3",115,0 ) ;                      -1 - er ror"RTN"," DGUTL3",11 6,0) Q:$G( DFN)="" -1  ;Quit wit h error if  missing i nput param eter"RTN", "DGUTL3",1 17,0) Q $P ($G(^DPT(D FN,.321)), "^",15)"RT N","DGUTL3 ",118,0) ; "RTN","DGU TL3",119,0 ) ; pwc DG *5.3*914 R SD SPEC# 2 .6.6.2.4 8 01 Screen  "RTN","DGU TL3",120,0 )GETCL(DFN ) ;Get cur rent value  of Camp L ejeune fro m Patient  file"RTN", "DGUTL3",1 21,0) ;    Input:  DF N - Patien t ien"RTN" ,"DGUTL3", 122,0) ;   Output: Va lid values  - 1 (Yes) , 0 (No),  or null"RT N","DGUTL3 ",123,0) ;                       -1 - error "RTN","DGU TL3",124,0 ) Q:$G(DFN )="" -1 ;Q uit with e rror if mi ssing inpu t paramete r"RTN","DG UTL3",125, 0) N CLV S  CLV=$P($G (^DPT(DFN, .3217)),"^ ",1)"RTN", "DGUTL3",1 26,0) Q $S (CLV="Y":1 ,CLV="N":0 ,1:"")"RTN ","VADPT0" )0^2^B1401 4645"RTN", "VADPT0",1 ,0)VADPT0  ;ALB/MRL/M JK,ERC,TDM  - PATIENT  VARIABLE  ROUTINE DR IVER, CONT . ; 02/22/ 2016"RTN", "VADPT0",2 ,0) ;;5.3; Registrati on;**343,3 42,415,489 ,498,528,6 89,789,688 ,759,754,8 87,914**;A ug 13, 199 3;Build 10 4"RTN","VA DPT0",3,0)  ;"RTN","V ADPT0",4,0 ) ;Initial ize variab les"RTN"," VADPT0",5, 0) N I1"RT N","VADPT0 ",6,0) S U ="^" D DT^ DICRW:'$D( DT)"RTN"," VADPT0",7, 0) S VAERR =$S($G(DFN )="":1,'$D (^DPT(DFN, 0)):1,1:0) "RTN","VAD PT0",8,0)  S Y=VAN'=1 3 I Y,$D(V AROOT)'[0, VAROOT]""  S Y=0,VAV= VAROOT K @ VAV"RTN"," VADPT0",9, 0) I Y S:$ S(VAN>9:1, '$D(VAHOW) :0,1:VAHOW [2) VAV="^ UTILITY("_ """"_VAV_" """_","_$J _")""RTN", "VADPT0",1 0,0) D @VA N"RTN","VA DPT0",11,0 )Q K X,Y,V AC,VAS,VAV ,VAW,VAN,I ,VAX,VAZ Q "RTN","VAD PT0",12,0)  ;"RTN","V ADPT0",13, 0)INIT ; - - determin e #'s or n ames then  init array "RTN","VAD PT0",14,0)  ;"RTN","V ADPT0",15, 0) S VAS=" 1^2^3^4^5^ 6^7^8^9^10 ^11^12^13^ 14^15^16^1 7^18^19^20 ^21^22^23^ 24^25^26^2 7^28^29""R TN","VADPT 0",16,0) I  VAN<10,$D (VAHOW),VA HOW[1 S VA S=$P($T(SS +VAN),";;" ,2)"RTN"," VADPT0",17 ,0) I $D(V AN(1)) F I =1:1:VAN(1 ) S @VAV@( $P(VAS,"^" ,I))="""RT N","VADPT0 ",18,0) Q" RTN","VADP T0",19,0)  ;"RTN","VA DPT0",20,0 )1 ; -- [D EM] demos  "RTN","VAD PT0",21,0)  D C1,INIT  I 'VAERR  D 1^VADPT1 ,13 Q"RTN" ,"VADPT0", 22,0) ;"RT N","VADPT0 ",23,0)2 ;  -- [OPD]  other pt v ars"RTN"," VADPT0",24 ,0) D C2,I NIT,2^VADP T1:'VAERR  Q"RTN","VA DPT0",25,0 ) ;"RTN"," VADPT0",26 ,0)3 ; --  [ADD] curr ent addres s"RTN","VA DPT0",27,0 ) D C3,INI T,3^VADPT1 :'VAERR Q" RTN","VADP T0",28,0)  ;"RTN","VA DPT0",29,0 )4 ; -- [O AD] other  pt vars"RT N","VADPT0 ",30,0) D  C4,INIT,4^ VADPT1:'VA ERR Q"RTN" ,"VADPT0", 31,0) ;"RT N","VADPT0 ",32,0)5 ;  -- [INP]  inpt data  -v5"RTN"," VADPT0",33 ,0) D C5,I NIT,5^VADP T2:'VAERR  Q"RTN","VA DPT0",34,0 ) ;"RTN"," VADPT0",35 ,0)6 ; --  [IN5] inpt  data v5"R TN","VADPT 0",36,0) D  C6,INIT F  I=13:1:17  F I1=1:1: 7 S @VAV@( $P(VAS,"^" ,I),I1)="" "RTN","VAD PT0",37,0)  F I=1:1:3  S @VAV@($ P(VAS,"^", 19),I)=""" RTN","VADP T0",38,0)  D 6^VADPT3 :'VAERR Q" RTN","VADP T0",39,0)  ;"RTN","VA DPT0",40,0 )7 ; -- [E LIG] elig  data"RTN", "VADPT0",4 1,0) D C7, INIT F I=1 :1:6 S @VA V@($P(VAS, "^",5),I)= """RTN","V ADPT0",42, 0) D 7^VAD PT4:'VAERR  Q"RTN","V ADPT0",43, 0) ;"RTN", "VADPT0",4 4,0)8 ; --  [MB] $ be nefits F I =2,6,7,8,9  F I1=3,4, 5 S @VAV@( $P(VAS,"^" ,I),I1)="" "RTN","VAD PT0",45,0)  D C8,INIT  D 8^VADPT 4:'VAERR Q "RTN","VAD PT0",46,0)  ;"RTN","V ADPT0",47, 0)9 ; -- [ SVC] servi ce data"RT N","VADPT0 ",48,0) ;  pwc DG*5.3 *914 RSD S PEC #2.6.1  Storing C amp Lejeun e Informat ion in Vis tA Added V ASV(15) ar ray"RTN"," VADPT0",49 ,0) D C9,I NIT F I=1: 1:9,15 S @ VAV@($P(VA S,"^",I),1 )="",@VAV@ ($P(VAS,"^ ",I),2)="" "RTN","VAD PT0",50,0)  S @VAV@($ P(VAS,"^", 10),1)=""" RTN","VADP T0",51,0)  F I=11:1:1 3 S @VAV@( $P(VAS,"^" ,I))=0"RTN ","VADPT0" ,52,0) S @ VAV@($P(VA S,"^",14), 1)="""RTN" ,"VADPT0", 53,0) S @V AV@($P(VAS ,"^",4),3) ="",@VAV@( $P(VAS,"^" ,5),3)="", @VAV@($P(V AS,"^",15) ,3)="""RTN ","VADPT0" ,54,0) F I =2,6,7,8 F  I1=3,4,5  S @VAV@($P (VAS,"^",I ),I1)="""R TN","VADPT 0",55,0) D  9^VADPT4: 'VAERR Q"R TN","VADPT 0",56,0) ; "RTN","VAD PT0",57,0) 10 ; -- [R EG] regist ration dat a"RTN","VA DPT0",58,0 ) D C10,IN IT D 10^VA DPT5:'VAER R Q"RTN"," VADPT0",59 ,0) ;"RTN" ,"VADPT0", 60,0)11 ;  -- [SDE] c linic enro llment dat a"RTN","VA DPT0",61,0 ) D C11,IN IT D 11^VA DPT5:'VAER R Q"RTN"," VADPT0",62 ,0) ;"RTN" ,"VADPT0", 63,0)12 ;  -- [SDA] a ppt data"R TN","VADPT 0",64,0) D  C12,INIT  D 12^VADPT 5:'VAERR Q "RTN","VAD PT0",65,0)  ;"RTN","V ADPT0",66, 0)13 ; --  [PID] pt i d's"RTN"," VADPT0",67 ,0) S (VA( "PID"),VA( "BID"))=""  D 13^VADP T6:'VAERR  Q"RTN","VA DPT0",68,0 ) ;"RTN"," VADPT0",69 ,0)KVAR ;  kill all v adpt data" RTN","VADP T0",70,0)  K VAN"RTN" ,"VADPT0", 71,0)C1 K  ^UTILITY(" VADM",$J), VADM Q:$D( VAN)"RTN", "VADPT0",7 2,0)C2 K ^ UTILITY("V APD",$J),V APD Q:$D(V AN)"RTN"," VADPT0",73 ,0)C3 K X  S:$D(VAPA( "P")) X("P ")=VAPA("P ")"RTN","V ADPT0",74, 0) S:$D(VA PA("CD"))  X("CD")=VA PA("CD")"R TN","VADPT 0",75,0) K  ^UTILITY( "VAPA",$J) ,VAPA"RTN" ,"VADPT0", 76,0) S:$D (X("P")) V APA("P")=X ("P") K X( "P")"RTN", "VADPT0",7 7,0) S:$D( X("CD")) V APA("CD")= X("CD") K  X Q:$D(VAN )"RTN","VA DPT0",78,0 )C4 K X S: $D(VAOA("A ")) X("A") =VAOA("A") "RTN","VAD PT0",79,0)  K ^UTILIT Y("VAOA",$ J),VAOA"RT N","VADPT0 ",80,0) S: $D(X("A"))  VAOA("A") =X("A") K  X Q:$D(VAN )"RTN","VA DPT0",81,0 )C5 K ^UTI LITY("VAIN ",$J),VAIN  Q:$D(VAN) "RTN","VAD PT0",82,0) C6 K X F I ="D","E"," L","M","V"  I $D(VAIP (I)) S X(I )=VAIP(I)" RTN","VADP T0",83,0)  S Y=$S('$D (VAIP("V") ):"VAIP",V AIP("V")'? 1A.E:"VAIP ",1:VAIP(" V")) K ^UT ILITY(Y,$J ),@Y"RTN", "VADPT0",8 4,0) F I=" D","E","L" ,"M","V" I  $D(X(I))  S VAIP(I)= X(I)"RTN", "VADPT0",8 5,0) K X Q :$D(VAN)"R TN","VADPT 0",86,0)C7  K ^UTILIT Y("VAEL",$ J),VAEL Q: $D(VAN)"RT N","VADPT0 ",87,0)C8  K ^UTILITY ("VAMB",$J ),VAMB Q:$ D(VAN)"RTN ","VADPT0" ,88,0)C9 K  ^UTILITY( "VASV",$J) ,VASV Q:$D (VAN)"RTN" ,"VADPT0", 89,0)C10 K  ^UTILITY( "VARP",$J)  Q:$D(VAN) "RTN","VAD PT0",90,0) C11 K ^UTI LITY("VAEN ",$J) Q:$D (VAN)"RTN" ,"VADPT0", 91,0)C12 K  ^UTILITY( "VASD",$J)  Q"RTN","V ADPT0",92, 0)C13 Q"RT N","VADPT0 ",93,0) ;" RTN","VADP T0",94,0)  ; pwc DG*5 .3*914 RSD  SPEC #2.6 .1 Storing  Camp Leje une Inform ation in V istA - add ed CLV to  SS+9"RTN", "VADPT0",9 5,0)SS ;   1^ 2^ 3^ 4 ^ 5^ 6^ 7^  8^ 9^10^1 1^12^13^14 ^15^16^17^ 18^19^20^2 1^22^23^24 ^25^26^27^ 28"RTN","V ADPT0",96, 0) ;;NM^SS ^DB^AG^SX^ EX^RE^RA^R P^MS^ET^RC ^PL"RTN"," VADPT0",97 ,0) ;;BC^B S^FN^MN^MM ^OC^ES^WP" RTN","VADP T0",98,0)  ;;L1^L2^L3 ^CI^ST^ZP^ CO^PN^TS^T E^Z4^CCA^C L1^CL2^CL3 ^CCI^CST^C ZP^CCO^CCS ^CCE^CTY^P R^PC^CT^CP R^CPC^CCT^ CPN"RTN"," VADPT0",99 ,0) ;;L1^L 2^L3^CI^ST ^ZP^CO^PN^ NM^RE^Z4"R TN","VADPT 0",100,0)  ;;AN^DR^TS ^WL^RB^BS^ AD^AT^AF^P T^AP"RTN", "VADPT0",1 01,0) ;;MN ^TT^MD^MT^ WL^RB^DR^T S^MF^BS^RD ^PT^AN^LN^ PN^NN^DN^A P^FD"RTN", "VADPT0",1 02,0) ;;EL ^PS^SC^VT^ IN^TY^CN^E S^MT"RTN", "VADPT0",1 03,0) ;;AA ^HB^SS^PE^ MR^SI^DI^O R^GI"RTN", "VADPT0",1 04,0) ;;VN ^AO^IR^PW^ CS^S1^S2^S 3^PH^CV^OI F^OEF^UNK^ SHD^CLV"RT N","VADPT4 ")0^3^B469 48271"RTN" ,"VADPT4", 1,0)VADPT4  ;ALB/MRL, MJK,ERC,DI C,PWC - PA TIENT VARI ABLES ;12  DEC 1988 ; 10/13/10 4 :43pm"RTN" ,"VADPT4", 2,0) ;;5.3 ;Registrat ion;**343, 342,528,68 9,688,790, 797,935,91 4**;Aug 13 , 1993;Bui ld 104"RTN ","VADPT4" ,3,0)7 ;El igibility  [ELIG]"RTN ","VADPT4" ,4,0) F I= .15,.3,.31 ,.32,.36,. 361,"INE", "TYPE","VE T" S VAX(I )=$S($D(^D PT(DFN,I)) :^(I),1:"" )"RTN","VA DPT4",5,0)  S VAZ=$P( VAX(.36)," ^",1) S:$D (^DIC(8,+V AZ,0)) VAZ =VAZ_"^"_$ P(^(0),"^" ,1) S @VAV @($P(VAS," ^",1))=VAZ "RTN","VAD PT4",6,0)  S VAX=0 F  I=0:0 S VA X=$O(^DPT( DFN,"E",VA X)) Q:VAX' >0  S VAZ= VAX I $D(^ DIC(8,+VAZ ,0)),+@VAV @($P(VAS," ^"))'=VAZ  S VAZ=VAZ_ "^"_$P(^DI C(8,+VAZ,0 ),"^") S @ VAV@($P(VA S,"^",1),V AX)=VAZ"RT N","VADPT4 ",7,0) S V AZ=$P(VAX( .32),"^",3 ) S:$D(^DI C(21,+VAZ, 0)) VAZ=VA Z_"^"_$P(^ (0),"^",1)  S @VAV@($ P(VAS,"^", 2))=VAZ"RT N","VADPT4 ",8,0) S V AZ=$S($P(V AX(.3),"^" ,1)="Y":1, 1:0) S:VAZ  VAZ=VAZ_" ^"_$P(VAX( .3),"^",2)  S @VAV@($ P(VAS,"^", 3))=VAZ"RT N","VADPT4 ",9,0) S @ VAV@($P(VA S,"^",4))= $S(VAX("VE T")="Y":1, 1:0),VAZ=$ S(+$P(VAX( .15),"^",2 ):0,1:1),@ VAV@($P(VA S,"^",5))= VAZ"RTN"," VADPT4",10 ,0) I VAZ  F I=1:1:6  S @VAV@($P (VAS,"^",5 ),I)="" G  71"RTN","V ADPT4",11, 0) S VAZ=$ P(VAX(.15) ,"^",2),Y= VAZ X ^DD( "DD") S @V AV@($P(VAS ,"^",5),1) =VAZ_"^"_Y ,VAZ=$P(VA X("INE")," ^",1) S:VA Z]"" VAZ=V AZ_"^"_$P( "VAMC^REGI ONAL OFFIC E^RPC","^" ,VAZ) S @V AV@($P(VAS ,"^",5),2) =VAZ"RTN", "VADPT4",1 2,0) S @VA V@($P(VAS, "^",5),3)= $P(VAX("IN E"),"^",3) ,VAZ=$P(VA X("INE")," ^",4) S:$D (^DIC(5,+V AZ,0)) VAZ =VAZ_"^"_$ P(^(0),"^" ,1) S @VAV @($P(VAS," ^",5),4)=V AZ"RTN","V ADPT4",13, 0) S @VAV@ ($P(VAS,"^ ",5),5)=$P (VAX("INE" ),"^",6),@ VAV@($P(VA S,"^",5),6 )=$P(VAX(. 3),"^",7)" RTN","VADP T4",14,0)7 1 S VAZ=VA X("TYPE")  S:$D(^DG(3 91,+VAZ,0) ) VAZ=VAZ_ "^"_$P(^(0 ),"^",1) S  @VAV@($P( VAS,"^",6) )=VAZ"RTN" ,"VADPT4", 15,0) S @V AV@($P(VAS ,"^",7))=$ P(VAX(.31) ,"^",3),VA Z=$P(VAX(. 361),"^",1 ) S:VAZ]""  VAZ=VAZ_" ^"_$S(VAZ= "V":"VERIF IED",VAZ=" P":"PENDIN G VERIFICA TION",VAZ= "R":"PENDI NG RE-VERI FICATION", 1:"") S @V AV@($P(VAS ,"^",8))=V AZ"RTN","V ADPT4",16, 0) I $D(^D PT(DFN,0))  S VAX=$P( ^(0),"^",1 4),VAX=$G( ^DG(408.32 ,+VAX,0))  I VAX]"" S  @VAV@($P( VAS,"^",9) )=$P(VAX," ^",2)_"^"_ $P(VAX,"^" ,1)"RTN"," VADPT4",17 ,0) Q"RTN" ,"VADPT4", 18,0) ;"RT N","VADPT4 ",19,0)8 ; Monetary B enefits [M B]"RTN","V ADPT4",20, 0) N DGTOT VA"RTN","V ADPT4",21, 0) S @VAV@ ($P(VAS,"^ ",6))=0 ;  SSI no lon ger suppor ted"RTN"," VADPT4",22 ,0) D ALL^ DGMTU21(DF N,"V",DT," I")"RTN"," VADPT4",23 ,0) S VAX= $G(^DGMT(4 08.21,+$G( DGINC("V") ),0)) F I= 8,11,13 S  @VAV@($S(I =8:$P(VAS, "^",3),I=1 1:$P(VAS," ^",5),1:$P (VAS,"^",8 )))=$S($P( VAX,"^",I) '="":"1^"_ $P(VAX,"^" ,I),1:0)"R TN","VADPT 4",24,0) S  VAX=$G(^D PT(DFN,.36 2))"RTN"," VADPT4",25 ,0) S DGTO TVA=$P(VAX ,U,20)"RTN ","VADPT4" ,26,0) F I =12,13,14  S @VAV@($S (I=12:$P(V AS,"^",1), (I=13):$P( VAS,"^",2) ,1:$P(VAS, "^",4)))=$ S($P(VAX," ^",I)="Y": 1_U_DGTOTV A,1:0)"RTN ","VADPT4" ,27,0) S I =17 S @VAV @($P(VAS," ^",9))=$S( $P(VAX,"^" ,17)="Y":1 _U_$P(VAX, U,6),1:0)" RTN","VADP T4",28,0)  S VAX=$G(^ DPT(DFN,.3 )) S @VAV@ ($P(VAS,"^ ",7))=$S($ P(VAX,"^", 11)="Y":1_ U_DGTOTVA, 1:0)"RTN", "VADPT4",2 9,0) K DGD EP,DGREL,D GINC,DGINR  Q"RTN","V ADPT4",30, 0) ;"RTN", "VADPT4",3 1,0)9 ;Ser vice infor mation"RTN ","VADPT4" ,32,0) ;pw c - DG*5.3 *914 RSD S PEC #2.6.1  Storing C amp Lejeun e Informat ion"RTN"," VADPT4",33 ,0) F I=.3 2,.321,.32 17,.3291,. 52,.53 S V AX(I)=$S($ D(^DPT(DFN ,I)):^(I), 1:"")"RTN" ,"VADPT4", 34,0) D:$D (^DPT(DFN, .3216)) MS DS"RTN","V ADPT4",35, 0) S VAX(" N")=.321 F  I=1,2,3 S  VAX(3)=I, VAZ=$S($P( VAX(.321), "^",I)="Y" :1,1:0),@V AV@($P(VAS ,"^",VAX(3 )))=VAZ I  VAZ S VAX( 1)=$S(I=1: "4^5",I=2: "7^9^8",1: 11),VAX(4) =0 D 91"RT N","VADPT4 ",36,0) S  VAX("N")=. 52 F I=5,1 1 S VAX(3) =$S(I=5:4, 1:5),VAX(1 )=$S(I=5:" 7^8",1:"13 ^14"),VAZ= $S($P(VAX( .52),"^",I )="Y":1,1: 0),@VAV@($ P(VAS,"^", VAX(3)))=V AZ I VAZ S  VAX(4)=0  D 91"RTN", "VADPT4",3 7,0) ;Comb at Vet"RTN ","VADPT4" ,38,0) S V AX(3)=10,V AX(1)="15" ,VAZ=$S($P (VAX(.52), U,15)]"":1 ,1:0),@VAV @($P(VAS,U ,VAX(3)))= VAZ I VAZ  S VAX(4)=0  D 91"RTN" ,"VADPT4", 39,0) F I= 6,7,8 S @V AV@($P(VAS ,"^",I))=" " F VAX(1) =1:1:6 S @ VAV@($P(VA S,"^",I),V AX(1))=""" RTN","VADP T4",40,0)  S VAX("N") =.32,VAZ=$ S($P(VAX(. 32),"^",5) ]"":1,1:0) ,@VAV@($P( VAS,"^",6) )=VAZ I VA Z,$P(VAX(. 32),"^",19 )="Y" S VA Z=1,@VAV@( $P(VAS,"^" ,7))=VAZ I  VAZ,$P(VA X(.32),"^" ,20)="Y" S  @VAV@($P( VAS,"^",8) )=1"RTN"," VADPT4",41 ,0) F I=6, 7,8 I @VAV @($P(VAS," ^",I)) S V AX(3)=I,VA X(1)=$S(I= 6:"6^7",I= 7:"11^12", 1:"16^17") ,VAX(4)=3  D 91"RTN", "VADPT4",4 2,0) S VAX ("N")=.329 1"RTN","VA DPT4",43,0 ) F I=6,7, 8 I @VAV@( $P(VAS,"^" ,I)) S VAX (3)=I,VAX( 1)=I-5,VAX (4)=6 D 94 "RTN","VAD PT4",44,0)  S VAX("N" )=.53,VAX( 3)=9,VAX(1 )="2^3",VA Z=$S($P(VA X(.53),U)= "Y":1,$P(V AX(.53),U) ="N":1,1:0 ),@VAV@($P (VAS,U,VAX (3)))=$S($ P(VAX(.53) ,U)="Y":1, $P(VAX(.53 ),U)="N":0 ,1:"") I V AZ S VAX(4 )=0 D 93"R TN","VADPT 4",45,0) S  VAX("N")= .3215,VAZ= $$GET^DGEN OEIF(DFN,. VAZ,1)"RTN ","VADPT4" ,46,0) ;OE F/OIF"RTN" ,"VADPT4", 47,0) F I= 11,12,13 S  @VAV@(I)= +$G(VAZ($P ("OIF^OEF^ UNK",U,I-1 0),"COUNT" ))"RTN","V ADPT4",48, 0) S VAX(2 )=11"RTN", "VADPT4",4 9,0) F I=" OIF","OEF" ,"UNK" S V AX=0 F  S  VAX=$O(VAZ (I,VAX)) S :'VAX VAX( 2)=VAX(2)+ 1 Q:'VAX   S VAX(3)=0  D"RTN","V ADPT4",50, 0) . N Z"R TN","VADPT 4",51,0) .  F VAX(1)= "LOC","FR" ,"TO" S VA X(3)=VAX(3 )+1,Z=$G(V AZ(I,VAX,V AX(1))),@V AV@(VAX(2) ,VAX,VAX(3 ))=Z D 95" RTN","VADP T4",52,0)  ;SHAD - ad ded with D G*5.3*688" RTN","VADP T4",53,0)  S VAX(3)=1 4,VAZ=$S($ P(VAX(.321 ),U,15)]"" :1,1:0),@V AV@($P(VAS ,U,VAX(3)) )=VAZ I VA Z S @VAV@( $P(VAS,U,V AX(3)),1)= $S($P(VAX( .321),U,15 )=1:"1^YES ",1:"0^NO" )"RTN","VA DPT4",54,0 ) ;pwc - D G*5.3*914  RSD SPEC # 2.6.1 Stor ing Camp L ejeune Inf ormation"R TN","VADPT 4",55,0) S  VAX(3)=15 ,VAZ=$S($P (VAX(.3217 ),U,1)="Y" :1,$P(VAX( .3217),U,1 )="N":0,1: ""),@VAV@( $P(VAS,U,V AX(3)))=VA Z I VAZ'=" " D"RTN"," VADPT4",56 ,0) . F I1 =1,2,3 S @ VAV@($P(VA S,U,VAX(3) ),I1)=$P(V AX(.3217), U,I1+1)"RT N","VADPT4 ",57,0) .  S X=@VAV@( $P(VAS,U,V AX(3)),1), Y=X I Y]""  X ^DD("DD ") S @VAV@ ($P(VAS,U, VAX(3)),1) =X_"^"_Y   ;get inter nal/extern al date"RT N","VADPT4 ",58,0) K  I1"RTN","V ADPT4",59, 0) Q"RTN", "VADPT4",6 0,0) ;"RTN ","VADPT4" ,61,0)91 ; date field s"RTN","VA DPT4",62,0 ) F VAX(2) =1:1 S VAX (4)=VAX(4) +1,X=+$P(V AX(1),"^", VAX(2)) Q: 'X  S X=$P (VAX(VAX(" N")),"^",X ),VAZ=X,Y= VAZ X:Y]""  ^DD("DD")  S @VAV@($ P(VAS,"^", VAX(3)),VA X(4))=$S(V AZ]"":VAZ_ "^"_Y,1:"" )"RTN","VA DPT4",63,0 ) Q:VAX(3) =1!(VAX(3) =9)!(VAX(3 )=10)"RTN" ,"VADPT4", 64,0) ;som e sets of  codes"RTN" ,"VADPT4", 65,0) I VA X(3)=2 S @ VAV@($P(VA S,"^",2),4 )=$P(VAX(. 321),"^",1 0) S (X,VA Z)=$P(VAX( .321),"^", 13) S:X]""  VAZ=VAZ_" ^"_$S(X="K ":"KOREAN  DMZ",1:"VI ETNAM") S  @VAV@($P(V AS,"^",2), 5)=VAZ Q"R TN","VADPT 4",66,0) I  VAX(3)<4  S X=$P(VAX (.321),"^" ,12),VAZ=X  D"RTN","V ADPT4",67, 0) .S:X]""  VAZ=VAZ_" ^"_$S(X="2 ":"HIROSHI MA/NAGASAK I",X="3":" ATMOSPHERI C NUCLEAR  TESTING",X ="4":"H/N  AND ATMOSP HERIC TEST ING",X="5" :"UNDERGRO UND NUCLEA R TESTING" ,X="6":"EX POSURE AT  NUCLEAR FA CILITY",1: "OTHER")"R TN","VADPT 4",68,0) . S @VAV@($P (VAS,"^",3 ),2)=VAZ Q "RTN","VAD PT4",69,0)  ;POW, com bat locati ons"RTN"," VADPT4",70 ,0) I VAX( 3)<6 S X=$ P(VAX(VAX( "N")),"^", $S(VAX(3)= 4:6,1:12)) ,VAZ=X S:$ D(^DIC(22, +X,0)) VAZ =VAZ_"^"_$ P(^(0),"^" ,1) S @VAV @($P(VAS," ^",VAX(3)) ,3)=VAZ Q" RTN","VADP T4",71,0)  ;service e pisodes"RT N","VADPT4 ",72,0) S  X=$S(VAX(3 )=6:5,VAX( 3)=7:10,1: 15),VAX(2) =0 F VAX(5 )=X,X+3,X- 1 S VAX(2) =VAX(2)+1, VAZ=$P(VAX (VAX("N")) ,"^",VAX(5 )),@VAV@($ P(VAS,"^", VAX(3)),VA X(2))=VAZ  I "^4^5^9^ 10^14^15^" [("^"_VAX( 5)_"^"),+V AZ D 92"RT N","VADPT4 ",73,0) Q" RTN","VADP T4",74,0)9 2 ;pointer s to Branc h of Servi ce (23) an d Type Dis charge (25 )"RTN","VA DPT4",75,0 ) S VAX(6) ="^DIC("_$ S('(VAX(5) #5):23,1:2 5)_","_+VA Z_",0)" I  $D(@(VAX(6 ))) S VAZ= $P(^(0),"^ ",1),@VAV@ ($P(VAS,"^ ",VAX(3)), VAX(2))=@V AV@($P(VAS ,"^",VAX(3 )),VAX(2)) _"^"_VAZ"R TN","VADPT 4",76,0) Q "RTN","VAD PT4",77,0) 93 ;Purple  Heart"RTN ","VADPT4" ,78,0) NEW  VAFILE,VA IENS,VAFLD S,VAARR,VA I"RTN","VA DPT4",79,0 ) S VAFILE =2,VAIENS= DFN_",",VA FLDS=".532 ;.533""RTN ","VADPT4" ,80,0) D G ETS^DIQ(VA FILE,VAIEN S,VAFLDS," IEN","VAAR R")"RTN"," VADPT4",81 ,0) F VAI= 1:1 S VAFL DS(VAI)=$P (VAFLDS,"; ",VAI) Q:V AFLDS(VAI) =""  D"RTN ","VADPT4" ,82,0) . I  '$D(VAARR (VAFILE,VA IENS,VAFLD S(VAI),"I" )),'$D(VAA RR(VAFILE, VAIENS,VAF LDS(VAI)," E")) S @VA V@($P(VAS, "^",VAX(3) ),VAI)=""" RTN","VADP T4",83,0)  . E  S @VA V@($P(VAS, U,VAX(3)), VAI)=$G(VA ARR(VAFILE ,VAIENS,VA FLDS(VAI), "I"))_"^"_ $G(VAARR(V AFILE,VAIE NS,VAFLDS( VAI),"E")) "RTN","VAD PT4",84,0)  Q"RTN","V ADPT4",85, 0)94 ;more  military  service"RT N","VADPT4 ",86,0) N  VAARR,VAIE NS,VAFLDS" RTN","VADP T4",87,0)  S VAIENS=D FN_",",VAF LDS=".3291 "_VAX(1)"R TN","VADPT 4",88,0) D  GETS^DIQ( 2,VAIENS,V AFLDS,"IEN ","VAARR") "RTN","VAD PT4",89,0)  I $G(VAAR R(2,VAIENS ,VAFLDS,"I "))'="" D" RTN","VADP T4",90,0)  . S @VAV@( $P(VAS,"^" ,VAX(3)),V AX(4))=$G( VAARR(2,VA IENS,VAFLD S,"I"))_"^ "_$G(VAARR (2,VAIENS, VAFLDS,"E" ))"RTN","V ADPT4",91, 0) Q"RTN", "VADPT4",9 2,0) ;"RTN ","VADPT4" ,93,0)95 ; OEF/OIF"RT N","VADPT4 ",94,0) N  X,Y"RTN"," VADPT4",95 ,0) I VAX( 3)=1 S $P( @VAV@(VAX( 2),VAX,VAX (3)),U,2)= $$EXTERNAL ^DILFD(2.3 215,.01,"" ,Z)"RTN"," VADPT4",96 ,0) I VAX( 3)=2!(VAX( 3)=3) S Y= Z X ^DD("D D") S:Y'=" " $P(@VAV@ (VAX(2),VA X,VAX(3)), U,2)=Y"RTN ","VADPT4" ,97,0) Q"R TN","VADPT 4",98,0) ; "RTN","VAD PT4",99,0) MSDS ;Retu rns latest  service e pisodes fr om ESR sou rced data" RTN","VADP T4",100,0)  N BRANCH, COUNT,COMP ,DA,DONE,D TYP,EDATA, EDATE,I,SD ATE,SERVNO ,SUB"RTN", "VADPT4",1 01,0) S CO UNT=0,EDAT E="""RTN", "VADPT4",1 02,0) ;Cle ar militar y service  discharge,  branch, s tart, end  and number  info"RTN" ,"VADPT4", 103,0) F I =4:1:20 S  $P(VAX(.32 ),U,I)=""" RTN","VADP T4",104,0)  ;Clear mi litary ser vice compo nent info" RTN","VADP T4",105,0)  F I=1:1:3  S $P(VAX( .3291),U,I )="""RTN", "VADPT4",1 06,0) ;Sca n back for  three mos t recent s ervice epi sodes"RTN" ,"VADPT4", 107,0) F   S EDATE=$O (^DPT(DFN, .3216,"B", EDATE),-1)  Q:'EDATE   D  Q:COUN T'<3"RTN", "VADPT4",1 08,0) .S D A=$O(^DPT( DFN,.3216, "B",EDATE, 0)) Q:'DA" RTN","VADP T4",109,0)  .;DJS, sk ip an MSE  that has F uture Disc harge Date ; DG*5.3*9 35"RTN","V ADPT4",110 ,0) .S EDA TA=$G(^DPT (DFN,.3216 ,DA,0)) Q: EDATA=""!( $P(EDATA,U ,8)'="")"R TN","VADPT 4",111,0)  .S COUNT=C OUNT+1,SDA TE=$P(EDAT A,U,2)"RTN ","VADPT4" ,112,0) .S  BRANCH=$P (EDATA,U,3 ),COMP=$P( EDATA,U,4) "RTN","VAD PT4",113,0 ) .S SERVN O=$P(EDATA ,U,5),DTYP =$P(EDATA, U,6)"RTN", "VADPT4",1 14,0) .;SL  = 4, SNL  = 9 or SNN L = 14"RTN ","VADPT4" ,115,0) .S  SUB=(COUN T*5)-1"RTN ","VADPT4" ,116,0) .S  $P(VAX(.3 2),U,SUB)= DTYP"RTN", "VADPT4",1 17,0) .S $ P(VAX(.32) ,U,SUB+1)= BRANCH"RTN ","VADPT4" ,118,0) .S  $P(VAX(.3 2),U,SUB+2 )=EDATE"RT N","VADPT4 ",119,0) . S $P(VAX(. 32),U,SUB+ 3)=SDATE"R TN","VADPT 4",120,0)  .S $P(VAX( .32),U,SUB +4)=SERVNO "RTN","VAD PT4",121,0 ) .S $P(VA X(.3291),U ,COUNT)=CO MP"RTN","V ADPT4",122 ,0) .S:SUB =9 $P(VAX( .32),U,19) ="Y""RTN", "VADPT4",1 23,0) .S:S UB=14 $P(V AX(.32),U, 20)="Y""RT N","VADPT4 ",124,0) Q "RTN","VAF HLZCL")0^6 1^B4425846 "RTN","VAF HLZCL",1,0 )VAFHLZCL  ;ALB/ESD -  Create ge neric HL7  ZCL Segmen t ;02-MAY- 1996"RTN", "VAFHLZCL" ,2,0) ;;5. 3;Registra tion;**94, 103,102,39 7,423,914* *;Aug 13,  1993;Build  104"RTN", "VAFHLZCL" ,3,0) ;"RT N","VAFHLZ CL",4,0) ;   This fun ction will  create VA -specific  ZCL segmen t(s) for a  "RTN","VA FHLZCL",5, 0) ;  give n outpatie nt encount er.  The Z CL segment  is design ed to tran sfer"RTN", "VAFHLZCL" ,6,0) ;  g eneric inf ormation a bout outpa tient clas sification s."RTN","V AFHLZCL",7 ,0) ;"RTN" ,"VAFHLZCL ",8,0) ;"R TN","VAFHL ZCL",9,0)E N(DFN,VAFE NC,VAFSTR, VAFHLQ,VAF HLFS,DNS   RY) ; Entr y point to  return th e HL7 ZCL  segment"RT N","VAFHLZ CL",10,0)  ;"RTN","VA FHLZCL",11 ,0) ;  Inp ut:      D FN - IEN o f the Pati ent (#2) f ile"RTN"," VAFHLZCL", 12,0) ;            VA FENC - IEN  of the Ou tpatient E ncounter ( #409.68) f ile"RTN"," VAFHLZCL", 13,0) ;            VA FSTR - Str ing of fie lds reques ted separa ted by com mas"RTN"," VAFHLZCL", 14,0) ;            VA FHLQ - Opt ional HL7  null varia ble. If no t there, u se "RTN"," VAFHLZCL", 15,0) ;                      def ault HL7 v ariable"RT N","VAFHLZ CL",16,0)  ;           VAFHLFS -  Optional  HL7 field  separator.  If not th ere, use " RTN","VAFH LZCL",17,0 ) ;                      default  HL7 varia ble"RTN"," VAFHLZCL", 18,0) ;           DNS   RY - Opt ional user -supplied  array name  which wil l hold ZCL  segments" RTN","VAFH LZCL",19,0 ) ;"RTN"," VAFHLZCL", 20,0) ; Ou tput:  Arr ay of HL7  ZCL segmen ts"RTN","V AFHLZCL",2 1,0) ;"RTN ","VAFHLZC L",22,0) ; "RTN","VAF HLZCL",23, 0) N I,VAF CLASS,VAFI DX,VAFY"RT N","VAFHLZ CL",24,0)  S DNS  RY= $G(DNS  RY )"RTN","VA FHLZCL",25 ,0) ;"RTN" ,"VAFHLZCL ",26,0) ;  - If DNS   RY not def ined, use  ^TMP("VAFH L",$J,"CLA SS")"RTN", "VAFHLZCL" ,27,0) S:( DNS  RY="" ) DNS  RY= "^TMP(""VA FHL"",$J," "CLASS"")" "RTN","VAF HLZCL",28, 0) ;"RTN", "VAFHLZCL" ,29,0) ; -  If VAFHLQ  or VAFHLF S aren't p assed in,  use defaul t HL7 vari ables"RTN" ,"VAFHLZCL ",30,0) S  VAFHLQ=$S( $D(VAFHLQ) :VAFHLQ,1: $G(HLQ)),V AFHLFS=$S( $D(VAFHLFS ):VAFHLFS, 1:$G(HLFS) )"RTN","VA FHLZCL",31 ,0) I '$G( DFN)!('$G( VAFENC))!( $G(VAFSTR) ']"") S @D NS  RY@(1, 0)="ZCL"_V AFHLFS_1 G  ENQ"RTN", "VAFHLZCL" ,32,0) S V AFIDX=0,VA FSTR=","_V AFSTR_","" RTN","VAFH LZCL",33,0 ) ;"RTN"," VAFHLZCL", 34,0)ALL ;  - All act ive outpat ient class ifications  for encou nter"RTN", "VAFHLZCL" ,35,0) S V AFCLASS=$$ CHKCLASS^S CDXUTL0(DF N,VAFENC)" RTN","VAFH LZCL",36,0 ) S VAFCLA SS=$G(VAFC LASS)"RTN" ,"VAFHLZCL ",37,0) I  '$D(VAFCLA SS) S @DNS   RY@(1,0) ="ZCL"_VAF HLFS_1 G E NQ"RTN","V AFHLZCL",3 8,0) ;"RTN ","VAFHLZC L",39,0) ;  - Build a rray of HL 7 (ZCL) se gments"RTN ","VAFHLZC L",40,0) F  I=1:1:$L( VAFCLASS," ^") D BUIL D"RTN","VA FHLZCL",41 ,0) ;"RTN" ,"VAFHLZCL ",42,0)ENQ  ;"RTN","V AFHLZCL",4 3,0) Q"RTN ","VAFHLZC L",44,0) ; "RTN","VAF HLZCL",45, 0) ;"RTN", "VAFHLZCL" ,46,0)BUIL D ; - Buil d for each  classific ation ques tion"RTN", "VAFHLZCL" ,47,0) S $ P(VAFY,VAF HLFS,3)="" ,VAFIDX=VA FIDX+1"RTN ","VAFHLZC L",48,0) ; "RTN","VAF HLZCL",49, 0) ; - Seq uential nu mber (requ ired field )"RTN","VA FHLZCL",50 ,0) S $P(V AFY,VAFHLF S,1)=VAFID X"RTN","VA FHLZCL",51 ,0) ;"RTN" ,"VAFHLZCL ",52,0) ;p wc RSD 2.6 .4.1.2 DG* 5.3*914 Ca mp Lejeune "RTN","VAF HLZCL",53, 0) ; - Cla ssificatio n type (1= AO,2=IR,3= SC,4=EC,5= MST,6=HNC, 7=CV,8=SHA D,9=CLV)"R TN","VAFHL ZCL",54,0)  I VAFSTR[ ",2," S $P (VAFY,VAFH LFS,2)=$S( $G(I)]"":I ,1:VAFHLQ)  ; Outpati ent Classi fication T ype"RTN"," VAFHLZCL", 55,0) ;"RT N","VAFHLZ CL",56,0)  ; - Value  (1=Yes, 0= No, ""=N/A )"RTN","VA FHLZCL",57 ,0) I VAFS TR[",3," S  $P(VAFY,V AFHLFS,3)= $S($P(VAFC LASS,"^",I )]"":$P(VA FCLASS,"^" ,I),1:VAFH LQ) ; Valu e"RTN","VA FHLZCL",58 ,0) ;"RTN" ,"VAFHLZCL ",59,0) ;  - If occas ion of ser vice, stuf f 0 (N) if  class val ue = Y"RTN ","VAFHLZC L",60,0) I  (VAFSTR[" ,3,"),($$C HKOCC^SCMS VDG1(VAFEN C)=1),($P( VAFY,VAFHL FS,3)=1) S  $P(VAFY,V AFHLFS,3)= 0"RTN","VA FHLZCL",61 ,0) ;"RTN" ,"VAFHLZCL ",62,0) ;  - Set all  outpatient  classific ations int o array"RT N","VAFHLZ CL",63,0)  S @DNS  RY @(VAFIDX,0 )="ZCL"_VA FHLFS_$G(V AFY)"RTN", "VAFHLZCL" ,64,0) Q"U P",45,45.0 2,-1)45^M" UP",45,45. 02,0)45.02 "VER")8.0^ 22.2"^DD", 45,45,79.3 3,0)TREATM ENT FOR CA MP LEJEUNE ^SX^Y:YES; N:NO;^70;3 3^Q"^DD",4 5,45,79.33 ,3)Was tre atment rel ated to Ca mp Lejeune ?"^DD",45, 45,79.33,2 1,0)^.001^ 4^4^317112 0^^^^"^DD" ,45,45,79. 33,21,1,0) For this V eteran, en ter "Y" if  the treat ment for t his encoun ter, visit ,"^DD",45, 45,79.33,2 1,2,0)or a dmission i s related  to a Veter an's Camp  Lejeune co ndition. E nter "N""^ DD",45,45, 79.33,21,3 ,0)if the  treatment  for this e ncounter,  visit, or  admission  is not rel ated"^DD", 45,45,79.3 3,21,4,0)t o a Vetera n's Camp L ejeune con dition."^D D",45,45,7 9.33,"DT") 3171120"^D D",45,45.0 2,33,0)TRE ATMENT FOR  CAMP LEJE UNE^SX^Y:Y ES;N:NO;^0 ;33^S DGFL AG=8 D 501 ^DGPTSPQ K :DGER X K  DGER,DGFLA G"^DD",45, 45.02,33,3 )Was treat ment relat ed to Camp  Lejeune?" ^DD",45,45 .02,33,21, 0)^.001^4^ 4^3171103^ ^^"^DD",45 ,45.02,33, 21,1,0)For  this Vete ran, enter  "Y" if th e treatmen t for this  encounter , visit,"^ DD",45,45. 02,33,21,2 ,0)or admi ssion is r elated to  a Veteran' s Camp Lej eune condi tion. Ente r "N""^DD" ,45,45.02, 33,21,3,0) if the tre atment for  this enco unter, vis it, or adm ission is  not relate d"^DD",45, 45.02,33,2 1,4,0)to a  Veteran's  Camp Leje une condit ion."^DD", 45,45.02,3 3,"DT")316 0330"^DD", 46.1,46.1, .1,0)TREAT MENT FOR C AMP LEJEUN E^S^1:YES; 0:NO;^0;10 ^Q"^DD",46 .1,46.1,.1 ,3)Was tre atment rel ated to Ca mp Lejeune ?"^DD",46. 1,46.1,.1, 21,0)^^4^4 ^3151207^" ^DD",46.1, 46.1,.1,21 ,1,0)For t his Vetera n, enter ' Y' if the  treatment  for this e ncounter,  visit,"^DD ",46.1,46. 1,.1,21,2, 0)or admis sion is re lated to a  Veteran's  Camp Leje une condit ion.  Ente r"^DD",46. 1,46.1,.1, 21,3,0)'N'  if the tr eatment fo r this enc ounter, vi sit, or ad mission is  not"^DD", 46.1,46.1, .1,21,4,0) related to  a Veteran 's Camp Le jeune cond ition."^DD ",46.1,46. 1,.1,"DT") 3151207"^D D",405,405 ,29,0)TREA TMENT FOR  CAMP LEJEU NE^RSX^Y:Y ES;N:NO;^C LV;1^Q"^DD ",405,405, 29,3)Was t reatment r elated to  Camp Lejeu ne?"^DD",4 05,405,29, 4)"^DD",40 5,405,29,2 1,0)^^12^1 2^3171120^ "^DD",405, 405,29,21, 1,0)If the  patient's  diagnosis  is for on e or more  of the 15  Camp Lejeu ne "^DD",4 05,405,29, 21,2,0)con ditions or  any secon dary condi tion relat ed to one  of these 1 5 Camp "^D D",405,405 ,29,21,3,0 )Lejeune c onditions,  enter 'YE S' or 'Y'.   Otherwis e answer ' NO' or 'N' ."^DD",405 ,405,29,21 ,4,0) "^DD ",405,405, 29,21,5,0)         1. Esophageal  cancer                      9.R enal toxic ity"^DD",4 05,405,29, 21,6,0)         2.Lun g cancer                            10.Hepa tic steato sis"^DD",4 05,405,29, 21,7,0)         3.Bre ast cancer                          11.Fema le inferti lity"^DD", 405,405,29 ,21,8,0)         4.Bl adder canc er                        12.Mis carriage"^ DD",405,40 5,29,21,9, 0)         5.Kidney c ancer                         13 .Scleroder ma"^DD",40 5,405,29,2 1,10,0)         6.Leu kemia                               14.Neur obehaviora l effects" ^DD",405,4 05,29,21,1 1,0)         7.Multip le myeloma                       15.Non-Hod gkin's lym phoma"^DD" ,405,405,2 9,21,12,0)         8. Myelodyspl astic synd romes"^DD" ,405,405,2 9,"DT")317 1120**INST ALL NAME** PX*1.0*207 "BLD",9233 ,0)PX*1.0* 207^PCE PA TIENT CARE  ENCOUNTER ^0^3180123 ^y"BLD",92 33,1,0)^^1 ^1^3180112 ^"BLD",923 3,1,1,0)Pl ease refer  to the pa tch descri ption for  details."B LD",9233,4 ,0)^9.64PA ^9000010.0 7^2"BLD",9 233,4,9000 010,0)9000 010"BLD",9 233,4,9000 010,2,0)^9 .641^90000 10^1"BLD", 9233,4,900 0010,2,900 0010,0)VIS IT  (File- top level) "BLD",9233 ,4,9000010 ,2,9000010 ,1,0)^9.64 11^80019^2 "BLD",9233 ,4,9000010 ,2,9000010 ,1,80009,0 )CAMP LEJE UNE"BLD",9 233,4,9000 010,2,9000 010,1,8001 9,0)CAMP L EJEUNE EDI T FLAG"BLD ",9233,4,9 000010,222 )y^y^p^^^^ n^^n"BLD", 9233,4,900 0010,224)" BLD",9233, 4,9000010. 07,0)90000 10.07"BLD" ,9233,4,90 00010.07,2 ,0)^9.641^ 9000010.07 ^1"BLD",92 33,4,90000 10.07,2,90 00010.07,0 )V POV  (F ile-top le vel)"BLD", 9233,4,900 0010.07,2, 9000010.07 ,1,0)^9.64 11^80009^1 "BLD",9233 ,4,9000010 .07,2,9000 010.07,1,8 0009,0)CAM P LEJEUNE" BLD",9233, 4,9000010. 07,222)y^y ^p^^^^n^^n "BLD",9233 ,4,9000010 .07,224)"B LD",9233,4 ,"APDD",90 00010,9000 010)"BLD", 9233,4,"AP DD",900001 0,9000010, 80009)"BLD ",9233,4," APDD",9000 010,900001 0,80019)"B LD",9233,4 ,"APDD",90 00010.07,9 000010.07) "BLD",9233 ,4,"APDD", 9000010.07 ,9000010.0 7,80009)"B LD",9233,4 ,"B",90000 10,9000010 )"BLD",923 3,4,"B",90 00010.07,9 000010.07) "BLD",9233 ,6.3)54"BL D",9233,"A BPKG")n"BL D",9233,"K RN",0)^9.6 7PA^779.2^ 20"BLD",92 33,"KRN",. 4,0).4"BLD ",9233,"KR N",.4,"NM" ,0)^9.68A^ ^"BLD",923 3,"KRN",.4 01,0).401" BLD",9233, "KRN",.402 ,0).402"BL D",9233,"K RN",.403,0 ).403"BLD" ,9233,"KRN ",.5,0).5" BLD",9233, "KRN",.84, 0).84"BLD" ,9233,"KRN ",3.6,0)3. 6"BLD",923 3,"KRN",3. 8,0)3.8"BL D",9233,"K RN",9.2,0) 9.2"BLD",9 233,"KRN", 9.2,"NM",0 )^9.68A^^" BLD",9233, "KRN",9.8, 0)9.8"BLD" ,9233,"KRN ",9.8,"NM" ,0)^9.68A^ 42^29"BLD" ,9233,"KRN ",9.8,"NM" ,2,0)PXAIC PTV^^0^B25 281544"BLD ",9233,"KR N",9.8,"NM ",3,0)PXAI PL^^0^B550 3263"BLD", 9233,"KRN" ,9.8,"NM", 4,0)PXAIPO V^^0^B2500 5398"BLD", 9233,"KRN" ,9.8,"NM", 5,0)PXAIVS T^^0^B1653 0572"BLD", 9233,"KRN" ,9.8,"NM", 6,0)PXBAPI 21^^0^B333 08732"BLD" ,9233,"KRN ",9.8,"NM" ,7,0)PXBDP OV^^0^B328 61915"BLD" ,9233,"KRN ",9.8,"NM" ,8,0)PXBIB B^^0^B1817 7835"BLD", 9233,"KRN" ,9.8,"NM", 9,0)PXBPL^ ^0^B266688 58"BLD",92 33,"KRN",9 .8,"NM",16 ,0)PXCEAPP M^^0^B7103 705"BLD",9 233,"KRN", 9.8,"NM",1 7,0)PXCECC LS^^0^B260 56884"BLD" ,9233,"KRN ",9.8,"NM" ,18,0)PXCE D800^^0^B2 921974"BLD ",9233,"KR N",9.8,"NM ",19,0)PXC EE800^^0^B 2266029"BL D",9233,"K RN",9.8,"N M",20,0)PX CEPOV^^0^B 14605990"B LD",9233," KRN",9.8," NM",21,0)P XCESIT^^0^ B10473456" BLD",9233, "KRN",9.8, "NM",22,0) PXCEVST^^0 ^B7001683" BLD",9233, "KRN",9.8, "NM",23,0) PXKFVST^^0 ^B14055512 "BLD",9233 ,"KRN",9.8 ,"NM",24,0 )PXKVST^^0 ^B20117091 "BLD",9233 ,"KRN",9.8 ,"NM",26,0 )PXRPC^^0^ B169336970 "BLD",9233 ,"KRN",9.8 ,"NM",28,0 )PXUTLSCC^ ^0^B457236 93"BLD",92 33,"KRN",9 .8,"NM",29 ,0)PXAIVST V^^0^B6406 8519"BLD", 9233,"KRN" ,9.8,"NM", 30,0)PXBAP I1^^0^B594 80552"BLD" ,9233,"KRN ",9.8,"NM" ,32,0)PXBD CPT^^0^B52 472938"BLD ",9233,"KR N",9.8,"NM ",33,0)PXC EC800^^0^B 3740890"BL D",9233,"K RN",9.8,"N M",34,0)PX BGPOV^^0^B 12499529"B LD",9233," KRN",9.8," NM",35,0)P XBAPI22^^0 ^B10766424 "BLD",9233 ,"KRN",9.8 ,"NM",39,0 )VSITDEF^^ 0^B4368145 8"BLD",923 3,"KRN",9. 8,"NM",40, 0)VSITFLD^ ^0^B117182 32"BLD",92 33,"KRN",9 .8,"NM",41 ,0)VSITHLP ^^0^B18771 975"BLD",9 233,"KRN", 9.8,"NM",4 2,0)PXKFPO V^^0^B4042 635"BLD",9 233,"KRN", 9.8,"NM"," B","PXAICP TV",2)"BLD ",9233,"KR N",9.8,"NM ","B","PXA IPL",3)"BL D",9233,"K RN",9.8,"N M","B","PX AIPOV",4)" BLD",9233, "KRN",9.8, "NM","B"," PXAIVST",5 )"BLD",923 3,"KRN",9. 8,"NM","B" ,"PXAIVSTV ",29)"BLD" ,9233,"KRN ",9.8,"NM" ,"B","PXBA PI1",30)"B LD",9233," KRN",9.8," NM","B","P XBAPI21",6 )"BLD",923 3,"KRN",9. 8,"NM","B" ,"PXBAPI22 ",35)"BLD" ,9233,"KRN ",9.8,"NM" ,"B","PXBD CPT",32)"B LD",9233," KRN",9.8," NM","B","P XBDPOV",7) "BLD",9233 ,"KRN",9.8 ,"NM","B", "PXBGPOV", 34)"BLD",9 233,"KRN", 9.8,"NM"," B","PXBIBB ",8)"BLD", 9233,"KRN" ,9.8,"NM", "B","PXBPL ",9)"BLD", 9233,"KRN" ,9.8,"NM", "B","PXCEA PPM",16)"B LD",9233," KRN",9.8," NM","B","P XCEC800",3 3)"BLD",92 33,"KRN",9 .8,"NM","B ","PXCECCL S",17)"BLD ",9233,"KR N",9.8,"NM ","B","PXC ED800",18) "BLD",9233 ,"KRN",9.8 ,"NM","B", "PXCEE800" ,19)"BLD", 9233,"KRN" ,9.8,"NM", "B","PXCEP OV",20)"BL D",9233,"K RN",9.8,"N M","B","PX CESIT",21) "BLD",9233 ,"KRN",9.8 ,"NM","B", "PXCEVST", 22)"BLD",9 233,"KRN", 9.8,"NM"," B","PXKFPO V",42)"BLD ",9233,"KR N",9.8,"NM ","B","PXK FVST",23)" BLD",9233, "KRN",9.8, "NM","B"," PXKVST",24 )"BLD",923 3,"KRN",9. 8,"NM","B" ,"PXRPC",2 6)"BLD",92 33,"KRN",9 .8,"NM","B ","PXUTLSC C",28)"BLD ",9233,"KR N",9.8,"NM ","B","VSI TDEF",39)" BLD",9233, "KRN",9.8, "NM","B"," VSITFLD",4 0)"BLD",92 33,"KRN",9 .8,"NM","B ","VSITHLP ",41)"BLD" ,9233,"KRN ",19,0)19" BLD",9233, "KRN",19," NM",0)^9.6 8A^^"BLD", 9233,"KRN" ,19.1,0)19 .1"BLD",92 33,"KRN",1 01,0)101"B LD",9233," KRN",409.6 1,0)409.61 "BLD",9233 ,"KRN",771 ,0)771"BLD ",9233,"KR N",779.2,0 )779.2"BLD ",9233,"KR N",870,0)8 70"BLD",92 33,"KRN",8 989.51,0)8 989.51"BLD ",9233,"KR N",8989.52 ,0)8989.52 "BLD",9233 ,"KRN",899 4,0)8994"B LD",9233," KRN",8994, "NM",0)^9. 68A^1^1"BL D",9233,"K RN",8994," NM",1,0)PX  SAVE DATA ^^0"BLD",9 233,"KRN", 8994,"NM", "B","PX SA VE DATA",1 )"BLD",923 3,"KRN","B ",.4,.4)"B LD",9233," KRN","B",. 401,.401)" BLD",9233, "KRN","B", .402,.402) "BLD",9233 ,"KRN","B" ,.403,.403 )"BLD",923 3,"KRN","B ",.5,.5)"B LD",9233," KRN","B",. 84,.84)"BL D",9233,"K RN","B",3. 6,3.6)"BLD ",9233,"KR N","B",3.8 ,3.8)"BLD" ,9233,"KRN ","B",9.2, 9.2)"BLD", 9233,"KRN" ,"B",9.8,9 .8)"BLD",9 233,"KRN", "B",19,19) "BLD",9233 ,"KRN","B" ,19.1,19.1 )"BLD",923 3,"KRN","B ",101,101) "BLD",9233 ,"KRN","B" ,409.61,40 9.61)"BLD" ,9233,"KRN ","B",771, 771)"BLD", 9233,"KRN" ,"B",779.2 ,779.2)"BL D",9233,"K RN","B",87 0,870)"BLD ",9233,"KR N","B",898 9.51,8989. 51)"BLD",9 233,"KRN", "B",8989.5 2,8989.52) "BLD",9233 ,"KRN","B" ,8994,8994 )"BLD",923 3,"QDEF")^ ^^^NO^^^^N O^^NO"BLD" ,9233,"QUE S",0)^9.62 ^^"BLD",92 33,"REQB", 0)^9.611^9 ^2"BLD",92 33,"REQB", 8,0)PX*1.0 *199^1"BLD ",9233,"RE QB",9,0)PX *1.0*216^1 "BLD",9233 ,"REQB","B ","PX*1.0* 199",8)"BL D",9233,"R EQB","B"," PX*1.0*216 ",9)"FIA", 9000010)VI SIT"FIA",9 000010,0)^ AUPNVSIT(" FIA",90000 10,0,0)900 0010sID"FI A",9000010 ,0,1)y^y^p ^^^^n^^n"F IA",900001 0,0,10)"FI A",9000010 ,0,11)"FIA ",9000010, 0,"RLRO")" FIA",90000 10,0,"VR") 1.0^PX"FIA ",9000010, 9000010)1" FIA",90000 10,9000010 ,80009)"FI A",9000010 ,9000010,8 0019)"FIA" ,9000010.0 7)V POV"FI A",9000010 .07,0)^AUP NVPOV("FIA ",9000010. 07,0,0)900 0010.07IP" FIA",90000 10.07,0,1) y^y^p^^^^n ^^n"FIA",9 000010.07, 0,10)"FIA" ,9000010.0 7,0,11)"FI A",9000010 .07,0,"RLR O")"FIA",9 000010.07, 0,"VR")1.0 ^PX"FIA",9 000010.07, 9000010.07 )1"FIA",90 00010.07,9 000010.07, 80009)"KRN ",8994,330 8,-1)0^1"K RN",8994,3 308,0)PX S AVE DATA^S AVE^PXRPC^ 1^P^^^^^^1 "KRN",8994 ,3308,1,0) ^8994.01^3 ^3^3171219 ^^^^"KRN", 8994,3308, 1,1,0)The  purpose of  this RPC  is to allo w the call ing applic ation to s ave data " KRN",8994, 3308,1,2,0 )to PCE, s uch as Imm unization  data. See  the Integr ation Cont rol "KRN", 8994,3308, 1,3,0)Regi stration d ocument fo r the full  descripti on of the  data neede d."KRN",89 94,3308,2, 0)^8994.02 A^4^4"KRN" ,8994,3308 ,2,1,0)PCE LIST^2^100 00^1^1"KRN ",8994,330 8,2,1,1,0) ^^59^59^31 71219^"KRN ",8994,330 8,2,1,1,1, 0)PCELIST  (n)= HDR ^  Encounter  Inpatient ? ^ Note h as CPT cod es? ^ Visi t "KRN",89 94,3308,2, 1,1,2,0)               string [E ncounter l ocation; E ncounter d ate/time;  Encounter" KRN",8994, 3308,2,1,1 ,3,0)              Se rvice cate gory]  (RE QUIRED)"KR N",8994,33 08,2,1,1,4 ,0)         (n)=VST^D T^Encounte r date/tim e"KRN",899 4,3308,2,1 ,1,5,0)         (n)=V ST^PT^Enco unter pati ent (DFN)  (n)=VST^HL ^Encounter  location" KRN",8994, 3308,2,1,1 ,6,0)         (n)=VST ^VC^ Encou nter Servi ce Categor y"KRN",899 4,3308,2,1 ,1,7,0) "K RN",8994,3 308,2,1,1, 8,0)         If  appl icable:"KR N",8994,33 08,2,1,1,9 ,0)               "KR N",8994,33 08,2,1,1,1 0,0)         (n)=VST^ PR^ Parent  for secon dary visit "KRN",8994 ,3308,2,1, 1,11,0)         (n)=V ST^OL^ Out side Locat ion for Hi storical v isits"KRN" ,8994,3308 ,2,1,1,12, 0)         (n)=VST^SC ^ Service  Connected  related?"K RN",8994,3 308,2,1,1, 13,0)         (n)=VST ^AO^ Agent  Orange re lated?"KRN ",8994,330 8,2,1,1,14 ,0)         (n)=VST^I R^ Ionizin g Radiatio n related? "KRN",8994 ,3308,2,1, 1,15,0)         (n)=V ST^EC^ Env ironmental  Contamina tes relate d?"KRN",89 94,3308,2, 1,1,16,0)         (n) =VST^MST^  Military S exual Trau ma related ?"KRN",899 4,3308,2,1 ,1,17,0)         (n)= VST^HNC^ H ead and/or  Neck Canc er related ?"KRN",899 4,3308,2,1 ,1,18,0)         (n)= VST^CV^ Co mbat Vet r elated?"KR N",8994,33 08,2,1,1,1 9,0)         (n)=VST^ SHD^ Shipb oard Hazar d and Defe nse relate d?"KRN",89 94,3308,2, 1,1,20,0)         (n) =VST^CLV^  Camp Lejeu ne related ?"KRN",899 4,3308,2,1 ,1,21,0)         (n)= PRV(+:  ad d, -: dele te) ^ Prov ider IEN ^ ^^ Provide r Name ^"K RN",8994,3 308,2,1,1, 22,0)             Pri mary Provi der?"KRN", 8994,3308, 2,1,1,23,0 )        ( n)=POV(+:   add, -: d elete) ^ I CD diagnos is code ^  Category   ^ "KRN",89 94,3308,2, 1,1,24,0)              Narrative  (Diagnosi s descript ion) ^ Pri mary Diagn osis? ^"KR N",8994,33 08,2,1,1,2 5,0)             Prov ider Strin g ^ Add to  Problem L ist? ^^^ N ext commen t"KRN",899 4,3308,2,1 ,1,26,0)              sequence #  if saving  comments" KRN",8994, 3308,2,1,1 ,27,0)         (n)=CO M^COM (Com ments) ^ N ext commen t sequence  # ^ @ = n o "KRN",89 94,3308,2, 1,1,28,0)              comments  added"KRN" ,8994,3308 ,2,1,1,29, 0)         (n)=CPT (+ :  add, -:  delete) ^  Procedura l  CPT cod e ^ Catego ry ^ "KRN" ,8994,3308 ,2,1,1,30, 0)             Narrat ive (Proce dure descr iption) ^  Quantity ^  Provider  IEN"KRN",8 994,3308,2 ,1,1,31,0)              ^^^ [# o f modifier s;  Modifi er code/Mo difier IEN  ^ Next"KR N",8994,33 08,2,1,1,3 2,0)             comm ent sequen ce # ^"KRN ",8994,330 8,2,1,1,33 ,0)         (n)=IMM ( +:  add, - : delete)  ^ Immuniza tion IEN ^  Category  ^ "KRN",89 94,3308,2, 1,1,34,0)              Narrative  (Immuniza tion descr iption/nam e) ^ Serie s ^"KRN",8 994,3308,2 ,1,1,35,0)              Encounte r Provider  ^ Reactio n ^ Contra indicated?  ^ ^"KRN", 8994,3308, 2,1,1,36,0 )             Next co mment sequ ence # ^ C VX Code ^  Event Info  Source HL 7 "KRN",89 94,3308,2, 1,1,37,0)              Code;IEN  ^ Dose;Uni ts;Units I EN ^ Route  Name;HL7  Code;IEN ^ "KRN",8994 ,3308,2,1, 1,38,0)             A dmin Site  Name;HL7 C ode;IEN ^  Lot#;IEN ^  Manufactu rer ^"KRN" ,8994,3308 ,2,1,1,39, 0)             Expira tion Date  ^ Event Da te and Tim e ^ Orderi ng Provide r ^"KRN",8 994,3308,2 ,1,1,40,0)              VIS IEN/ VIS Date;  VIS IEN n/ VIS Date n  ^ Remarks  Start Seq "KRN",8994 ,3308,2,1, 1,41,0)             # ;Remarks E nd Seq # ^  Warning A ck ^ Overr ide Reason  (Seq #)"K RN",8994,3 308,2,1,1, 42,0)         (n)=SK  (+:  add,  -: delete)  ^ Skin Te st IEN ^ C ategory ^  "KRN",8994 ,3308,2,1, 1,43,0)             N arrative ( Skin Test  descriptio n/name) ^  Results ^E nc Provide r"KRN",899 4,3308,2,1 ,1,44,0)              ^ Reading  ^ D/T Read  ^ Event D /T ^ Next  comment se quence # ^ "KRN",8994 ,3308,2,1, 1,45,0)             R eader ^ Or dering Pro vider ^ An atomic Loc ation of " KRN",8994, 3308,2,1,1 ,46,0)             Pl acement;HL 7 Code;IEN  ^ Reading  Comment ( Seq #)"KRN ",8994,330 8,2,1,1,47 ,0)         (n)=PED ( +:  add, - : delete)  ^ Patient  Education  IEN ^ Cate gory ^ "KR N",8994,33 08,2,1,1,4 8,0)             Narr ative (Pat ient Educa tion descr iption/nam e) ^ Level  of"KRN",8 994,3308,2 ,1,1,49,0)              understa nding ^^^^ ^ ^^ Next  comment se quence #"K RN",8994,3 308,2,1,1, 50,0)         (n)=HF  (+:  add,  -: delete)  ^ Health  Factor IEN  ^ Categor y ^ "KRN", 8994,3308, 2,1,1,51,0 )             Narrati ve (Health  Factor de scription/ name) ^ Le vel ^^^^^  Next"KRN", 8994,3308, 2,1,1,52,0 )             comment  sequence  # ^ Get Re minder"KRN ",8994,330 8,2,1,1,53 ,0)         (n)=XAM(+ :  add, -:  delete) ^  Exam IEN  ^ Category  ^ Narrati ve "KRN",8 994,3308,2 ,1,1,54,0)              (Exam de scription/ name) ^ Re sults ^^^^ ^ Next com ment seque nce"KRN",8 994,3308,2 ,1,1,55,0)              #"KRN",8 994,3308,2 ,1,1,56,0)         (n )=ICR (+:   add, -: d elete) ^ V ariable Po inter IMM" KRN",8994, 3308,2,1,1 ,57,0)             Co ntraindica tion Reaso ns/IMM Ref usal Reaso ns ^ Categ ory ^"KRN" ,8994,3308 ,2,1,1,58, 0)             Narrat ive ^ Immu nization I EN ^ Warn  Until Date  ^ Event"K RN",8994,3 308,2,1,1, 59,0)             Dat e/Time ^ E nc Provide r IEN ^ ^  Next comme nt sequenc e #"KRN",8 994,3308,2 ,2,0)LOC^1 ^40^0^2"KR N",8994,33 08,2,2,1,0 )^^2^2^314 0225^"KRN" ,8994,3308 ,2,2,1,1,0 )This is t he hospita l location . This is  not used w hen the in formation  is "KRN",8 994,3308,2 ,2,1,2,0)f rom an out side sourc e."KRN",89 94,3308,2, 3,0)PKGNAM E^1^60^1^3 "KRN",8994 ,3308,2,3, 1,0)^^2^2^ 3140225^"K RN",8994,3 308,2,3,1, 1,0)The pa ckage name  that is s ending the  data to P CE. This s hould be t he "KRN",8 994,3308,2 ,3,1,2,0)f ull packag e name, su ch as PATI ENT CARE E NCOUNTERS.  "KRN",899 4,3308,2,4 ,0)SRC^1^6 0^1^4"KRN" ,8994,3308 ,2,4,1,0)^ 8994.021^1 ^1^3171219 ^^^^"KRN", 8994,3308, 2,4,1,1,0) The source  of the da ta - such  as VLER E- HEALTH EXC HANGE."KRN ",8994,330 8,2,5,0)PX  SAVE"KRN" ,8994,3308 ,2,6,0)SRC ^2^1000^1^ 1"KRN",899 4,3308,2," B","LOC",2 )"KRN",899 4,3308,2," B","PCELIS T",1)"KRN" ,8994,3308 ,2,"B","PC ELIST",4)" KRN",8994, 3308,2,"B" ,"PKGNAME" ,3)"KRN",8 994,3308,2 ,"B","PX S AVE",5)"KR N",8994,33 08,2,"B"," SRC",4)"KR N",8994,33 08,2,"B"," SRC",6)"KR N",8994,33 08,2,"PARA MSEQ",1,1) "KRN",8994 ,3308,2,"P ARAMSEQ",1 ,4)"KRN",8 994,3308,2 ,"PARAMSEQ ",1,6)"KRN ",8994,330 8,2,"PARAM SEQ",2,2)" KRN",8994, 3308,2,"PA RAMSEQ",3, 3)"KRN",89 94,3308,2, "PARAMSEQ" ,4,4)"KRN" ,8994,3308 ,3,0)^8994 .03^8^8^31 71219^^^^" KRN",8994, 3308,3,1,0 )The only  return wil l be the o ne passed  back to th e calling  applicatio n."KRN",89 94,3308,3, 2,0) "KRN" ,8994,3308 ,3,3,0)A - 2 indicate s that the  routine P XAI found  an issue e ven though  the "KRN" ,8994,3308 ,3,4,0)ori ginal inpu t values a ppeared to  be correc t."KRN",89 94,3308,3, 5,0) "KRN" ,8994,3308 ,3,6,0)A - 3 indicate s that the  input par ameters we re not pro perly defi ned."KRN", 8994,3308, 3,7,0) "KR N",8994,33 08,3,8,0)A  1 indicat e success. "MBREQ")0" ORD",16,89 94)8994;16 ;1;;;;;;;R PCDEL^XPDI A1"ORD",16 ,8994,0)RE MOTE PROCE DURE"PKG", 507,-1)1^1 "PKG",507, 0)PCE PATI ENT CARE E NCOUNTER^P X^Patient  Care Encou nter"PKG", 507,20,0)^ 9.402P^^"P KG",507,22 ,0)^9.49I^ 1^1"PKG",5 07,22,1,0) 1.0^296081 2^2960912^ 10958"PKG" ,507,22,1, "PAH",1,0) 207^318012 3^10000000 007"PKG",5 07,22,1,"P AH",1,1,0) ^^1^1^3180 123"PKG",5 07,22,1,"P AH",1,1,1, 0)Please r efer to th e patch de scription  for detail s."QUES"," XPF1",0)Y" QUES","XPF 1","??")^D  REP^XPDH" QUES","XPF 1","A")Sha ll I write  over your  |FLAG| Fi le"QUES"," XPF1","B") YES"QUES", "XPF1","M" )D XPF1^XP DIQ"QUES", "XPF2",0)Y "QUES","XP F2","??")^ D DTA^XPDH "QUES","XP F2","A")Wa nt my data  |FLAG| yo urs"QUES", "XPF2","B" )YES"QUES" ,"XPF2","M ")D XPF2^X PDIQ"QUES" ,"XPI1",0) YO"QUES"," XPI1","??" )^D INHIBI T^XPDH"QUE S","XPI1", "A")Want K IDS to INH IBIT LOGON s during t he install "QUES","XP I1","B")NO "QUES","XP I1","M")D  XPI1^XPDIQ "QUES","XP M1",0)PO^V A(200,:EM" QUES","XPM 1","??")^D  MG^XPDH"Q UES","XPM1 ","A")Ente r the Coor dinator fo r Mail Gro up '|FLAG| '"QUES","X PM1","B")" QUES","XPM 1","M")D X PM1^XPDIQ" QUES","XPO 1",0)Y"QUE S","XPO1", "??")^D ME NU^XPDH"QU ES","XPO1" ,"A")Want  KIDS to Re build Menu  Trees Upo n Completi on of Inst all"QUES", "XPO1","B" )NO"QUES", "XPO1","M" )D XPO1^XP DIQ"QUES", "XPZ1",0)Y "QUES","XP Z1","??")^ D OPT^XPDH "QUES","XP Z1","A")Wa nt to DISA BLE Schedu led Option s, Menu Op tions, and  Protocols "QUES","XP Z1","B")NO "QUES","XP Z1","M")D  XPZ1^XPDIQ "QUES","XP Z2",0)Y"QU ES","XPZ2" ,"??")^D R TN^XPDH"QU ES","XPZ2" ,"A")Want  to MOVE ro utines to  other CPUs "QUES","XP Z2","B")NO "QUES","XP Z2","M")D  XPZ2^XPDIQ "RTN")29"R TN","PXAIC PTV")0^2^B 25281544"R TN","PXAIC PTV",1,0)P XAICPTV ;I SL/JVS,ISA /KWP,SCK -  VALIDATE  PROCEDURES (CPT) ;11/ 14/96  12: 46"RTN","P XAICPTV",2 ,0) ;;1.0; PCE PATIEN T CARE ENC OUNTER;**1 5,73,74,11 1,121,130, 168,194,19 9,207**;Au g 12, 1996 ;Build 54" RTN","PXAI CPTV",3,0)  ;"RTN","P XAICPTV",4 ,0) ; edit ed to allo w Historic al Encount ers to use  ICD-10 co des even t hough Visi t Date is  pre-ICD-10 ."RTN","PX AICPTV",5, 0)VAL ;--V ALIDATE EN OUGH DATA" RTN","PXAI CPTV",6,0)  ;----Miss ing a poin ter to PRO CEDURE(CPT ) name"RTN ","PXAICPT V",7,0) I  $G(PXAA("P ROCEDURE") )']"" D  Q :$G(STOP)" RTN","PXAI CPTV",8,0)  .S STOP=1  ;--USED T O STOP DO  LOOP"RTN", "PXAICPTV" ,9,0) .S P XAERRF=1 ; --FLAG IND ICATES THE RE IS AN E RROR"RTN", "PXAICPTV" ,10,0) .S  PXADI("DIA LOG")=8390 001.001"RT N","PXAICP TV",11,0)  .S PXAERR( 9)="PROCED URE""RTN", "PXAICPTV" ,12,0) .S  PXAERR(11) =$G(PXAA(" PROCEDURE" ))"RTN","P XAICPTV",1 3,0) .S PX AERR(12)=" You are mi ssing a po inter to t he PROCEDU RE CPT FIL E #81 that  represent s the proc edure's na me""RTN"," PXAICPTV", 14,0) ;"RT N","PXAICP TV",15,0)  ;----NOT a  pointer t o PROCEDUR E CPT FILE #81"RTN"," PXAICPTV", 16,0) I +$ $CPT^ICPTC OD($G(PXAA ("PROCEDUR E")))'>0 D   Q:$G(STO P)"RTN","P XAICPTV",1 7,0) .S ST OP=1"RTN", "PXAICPTV" ,18,0) .S  PXAERRF=1" RTN","PXAI CPTV",19,0 ) .S PXADI ("DIALOG") =8390001.0 01"RTN","P XAICPTV",2 0,0) .S PX AERR(9)="P ROCEDURE"" RTN","PXAI CPTV",21,0 ) .S PXAER R(11)=$G(P XAA("PROCE DURE"))"RT N","PXAICP TV",22,0)  .S PXAERR( 12)=PXAERR (11)_" is  NOT a poin ter value  to the CPT  FILE #81" "RTN","PXA ICPTV",23, 0) ;"RTN", "PXAICPTV" ,24,0) ;-- --Not a va lid CPT"RT N","PXAICP TV",25,0)  I '$P($$CP T^ICPTCOD( PXAA("PROC EDURE"),+^ AUPNVSIT(P XAVISIT,0) ),"^",7) D   Q:$G(STO P)"RTN","P XAICPTV",2 6,0) .S ST OP=1"RTN", "PXAICPTV" ,27,0) .S  PXAERRF=1" RTN","PXAI CPTV",28,0 ) .S PXADI ("DIALOG") =8390001.0 01"RTN","P XAICPTV",2 9,0) .S PX AERR(9)="P ROCEDURE"" RTN","PXAI CPTV",30,0 ) .S PXAER R(11)=$G(P XAA("PROCE DURE"))"RT N","PXAICP TV",31,0)  .S PXAERR( 12)=PXAERR (11)_" is  NOT a vali d CPT code ""RTN","PX AICPTV",32 ,0) ;"RTN" ,"PXAICPTV ",33,0) ;- ---Not a v alid modif ier"RTN"," PXAICPTV", 34,0) N SU B,MODIEN"R TN","PXAIC PTV",35,0)  S SUB=""" RTN","PXAI CPTV",36,0 ) F  S SUB =$O(PXAA(" MODIFIERS" ,SUB)) Q:S UB=""!($G( STOP))  D" RTN","PXAI CPTV",37,0 ) .;S MODI EN=$$MODP^ ICPTMOD(PX AA("PROCED URE"),SUB, "E","",0)" RTN","PXAI CPTV",38,0 ) .S MODIE N=$$MODP^I CPTMOD(PXA A("PROCEDU RE"),SUB," E",+^AUPNV SIT(PXAVIS IT,0),0)"R TN","PXAIC PTV",39,0)  .I $P(MOD IEN,"^")>0  Q"RTN","P XAICPTV",4 0,0) .S ST OP=1"RTN", "PXAICPTV" ,41,0) .S  PXAERRF=1" RTN","PXAI CPTV",42,0 ) .S PXADI ("DIALOG") =8390001.0 01"RTN","P XAICPTV",4 3,0) .S PX AERR(9)="M ODIFIERS"_ ","_SUB"RT N","PXAICP TV",44,0)  .S PXAERR( 11)="""RTN ","PXAICPT V",45,0) . S PXAERR(1 2)=SUB_" i s NOT a va lid modifi er for pro cedure "_$ G(PXAA("PR OCEDURE")) "RTN","PXA ICPTV",46, 0) ;----"M issing the  number of  times the  procedure  was perfo rmed."RTN" ,"PXAICPTV ",47,0) I  $G(PXAA("Q TY"))<1 D" RTN","PXAI CPTV",48,0 ) .S STOP= 0"RTN","PX AICPTV",49 ,0) .S PXA ERRF=1"RTN ","PXAICPT V",50,0) . S PXADI("D IALOG")=83 90001.002" RTN","PXAI CPTV",51,0 ) .S PXAER R(9)="QTY" "RTN","PXA ICPTV",52, 0) .S PXAE RR(11)=$G( PXAA("QTY" ))"RTN","P XAICPTV",5 3,0) .S PX AERR(12)=" If this no de is empt y we will  assume it  should be  '1'. If it  is a less  than '1'  we will de lete any r eference t o it in th e data bas e.""RTN"," PXAICPTV", 54,0) ;"RT N","PXAICP TV",55,0)  Q:$G(STOP) =1"RTN","P XAICPTV",5 6,0) N DIA GNUM,DIAGS TR,ICDDATA ,PXDXDATE" RTN","PXAI CPTV",57,0 ) S PXDXDA TE=$$CSDAT E^PXDXUTL( PXAVISIT)" RTN","PXAI CPTV",58,0 ) ;"RTN"," PXAICPTV", 59,0) F DI AGNUM=1:1: 8 D  Q:$G( STOP)=1"RT N","PXAICP TV",60,0)  . S DIAGST R="DIAGNOS IS"_$S(DIA GNUM>1:" " _DIAGNUM,1 :"")"RTN", "PXAICPTV" ,61,0) . I  $G(PXAA(D IAGSTR))]" " D"RTN"," PXAICPTV", 62,0) .. S  ICDDATA=$ $ICDDATA^I CDXCODE("D IAG",$G(PX AA(DIAGSTR )),PXDXDAT E,"I")"RTN ","PXAICPT V",63,0) . . I $P(ICD DATA,"^",1 )'>0 D  Q: $G(STOP)=1 "RTN","PXA ICPTV",64, 0) ... S S TOP=1"RTN" ,"PXAICPTV ",65,0) .. . S PXAERR F=1"RTN"," PXAICPTV", 66,0) ...  S PXADI("D IALOG")=83 90001.001" RTN","PXAI CPTV",67,0 ) ... S PX AERR(9)="P ROCEDURE"" RTN","PXAI CPTV",68,0 ) ... S PX AERR(11)=$ G(PXAA(DIA GSTR))"RTN ","PXAICPT V",69,0) . .. S PXAER R(12)="PRO CEDURE DIA GNOSIS #"_ DIAGNUM_"  ("_PXAERR( 11)_") is  NOT a vali d pointer  value to t he ICD DIA GNOSIS FIL E #80""RTN ","PXAICPT V",70,0) . . I $P(ICD DATA,"^",1 0)'=1 D  Q :$G(STOP)= 1"RTN","PX AICPTV",71 ,0) ... S  STOP=1"RTN ","PXAICPT V",72,0) . .. S PXAER RF=1"RTN", "PXAICPTV" ,73,0) ...  S PXADI(" DIALOG")=8 390001.001 "RTN","PXA ICPTV",74, 0) ... S P XAERR(9)=" PROCEDURE" "RTN","PXA ICPTV",75, 0) ... S P XAERR(11)= $G(PXAA(DI AGSTR))"RT N","PXAICP TV",76,0)  ... S PXAE RR(12)="PR OCEDURE DI AGNOSIS #" _DIAGNUM_"  ("_PXAERR (11)_") is  NOT an Ac tive ICD c ode""RTN", "PXAICPTV" ,77,0) ;"R TN","PXAIC PTV",78,0)  ;"RTN","P XAICPTV",7 9,0) Q"RTN ","PXAICPT V",80,0)VA L04 ;---PR OVIDER NAR RATIVE"RTN ","PXAICPT V",81,0) S  STOP=1"RT N","PXAICP TV",82,0)  S PXAERRF= 1"RTN","PX AICPTV",83 ,0) S PXAD I("DIALOG" )=8390001. 001"RTN"," PXAICPTV", 84,0) S PX AERR(9)="N ARRATIVE"" RTN","PXAI CPTV",85,0 ) S PXAERR (11)=$G(PX AA("NARRAT IVE"))"RTN ","PXAICPT V",86,0) S  PXAERR(12 )="We are  unable to  retrieve a  narrative  from the  PROVIDER N ARRATIVE f ile #99999 99.27""RTN ","PXAICPT V",87,0) Q "RTN","PXA ICPTV",88, 0)VAL45 ;- --PROVIDER  NARRATIVE  CATEGORY" RTN","PXAI CPTV",89,0 ) S STOP=0 "RTN","PXA ICPTV",90, 0) S PXAER RF=1"RTN", "PXAICPTV" ,91,0) S P XADI("DIAL OG")=83900 01.002"RTN ","PXAICPT V",92,0) S  PXAERR(9) ="CATEGORY ""RTN","PX AICPTV",93 ,0) S PXAE RR(11)=$G( PXAA("CATE GORY"))"RT N","PXAICP TV",94,0)  S PXAERR(1 2)="We are  unable to  retrieve  a narrativ e from the  PROVIDER  NARRATIVE  file #9999 999.27""RT N","PXAICP TV",95,0)  Q"RTN","PX AICPTV",96 ,0) ;----- ---------- ------SUBR OUTINE---- ---------- ---------- ------"RTN ","PXAICPT V",97,0)AR RAY ;--SET  ERRORS AN D WARNINGS  INTO AN A RRAY TO RE TURN TO CA LLER"RTN", "PXAICPTV" ,98,0) I P XADI("DIAL OG")=83900 01.001 D"R TN","PXAIC PTV",99,0)  .S PXASUB =PXASUB+1" RTN","PXAI CPTV",100, 0) .S PXAP ROB($J,PXA SUB,"ERROR 1",PXAERR( 7),PXAERR( 9),PXAK)=$ G(PXAERR(1 2))"RTN"," PXAICPTV", 101,0) I P XADI("DIAL OG")=83900 01.002 D"R TN","PXAIC PTV",102,0 ) .S PXASU B=PXASUB+1 "RTN","PXA ICPTV",103 ,0) .S PXA PROB($J,PX ASUB,"WARN ING2",PXAE RR(7),PXAE RR(9),PXAK )=$G(PXAER R(12))"RTN ","PXAICPT V",104,0)  I PXADI("D IALOG")=83 90001.003  D"RTN","PX AICPTV",10 5,0) .S PX ASUB=PXASU B+1"RTN"," PXAICPTV", 106,0) .S  PXAPROB($J ,PXASUB,"W ARNING3"," ENCOUNTER" ,1,"SC")=$ G(PXAERR(" 6W"))"RTN" ,"PXAICPTV ",107,0) . S PXAPROB( $J,PXASUB, "WARNING3" ,"ENCOUNTE R",1,"AO") =$G(PXAERR ("7W"))"RT N","PXAICP TV",108,0)  .S PXAPRO B($J,PXASU B,"WARNING 3","ENCOUN TER",1,"IR ")=$G(PXAE RR("8W"))" RTN","PXAI CPTV",109, 0) .S PXAP ROB($J,PXA SUB,"WARNI NG3","ENCO UNTER",1," EC")=$G(PX AERR("9W") )"RTN","PX AICPTV",11 0,0) .S PX APROB($J,P XASUB,"WAR NING3","EN COUNTER",1 ,"MST")=$G (PXAERR("1 0W"))"RTN" ,"PXAICPTV ",111,0) . ;PX*1*111  - Add HNC" RTN","PXAI CPTV",112, 0) .S PXAP ROB($J,PXA SUB,"WARNI NG3","ENCO UNTER",1," HNC")=$G(P XAERR("17W "))"RTN"," PXAICPTV", 113,0) .S  PXAPROB($J ,PXASUB,"W ARNING3"," ENCOUNTER" ,1,"CV")=$ G(PXAERR(" 18W"))"RTN ","PXAICPT V",114,0)  .S PXAPROB ($J,PXASUB ,"WARNING3 ","ENCOUNT ER",1,"SHA D")=$G(PXA ERR("19W") )"RTN","PX AICPTV",11 5,0) .;  d js  PX*1.0 *207  RSD  SPEC# 2.6. 2.1.1  Add  warning f or Camp Le jeune Ind. "RTN","PXA ICPTV",116 ,0) .S PXA PROB($J,PX ASUB,"WARN ING3","ENC OUNTER",1, "CLV")=$G( PXAERR("20 W"))"RTN", "PXAICPTV" ,117,0) I  PXADI("DIA LOG")=8390 001.004 D" RTN","PXAI CPTV",118, 0) .S PXAS UB=PXASUB+ 1"RTN","PX AICPTV",11 9,0) .S PX APROB($J,P XASUB,"ERR OR4","PX/D L",PXAK)=$ G(PXAERR(" PL1"))"RTN ","PXAICPT V",120,0)  Q"RTN","PX AIPL")0^3^ B5503263"R TN","PXAIP L",1,0)PXA IPL ;ISL/J VS - PROBL EM LIST ;2 4 Jan 2013   12:59 PM "RTN","PXA IPL",2,0)  ;;1.0;PCE  PATIENT CA RE ENCOUNT ER;**69,12 4,168,199, 207**;Aug  12, 1996;B uild 54"RT N","PXAIPL ",3,0) ;"R TN","PXAIP L",4,0) ;" RTN","PXAI PL",5,0) Q "RTN","PXA IPL",6,0)P L ;--ENTRY  POINT TO  EDIT PROBL EMS"RTN"," PXAIPL",7, 0) ;"RTN", "PXAIPL",8 ,0) ;"RTN" ,"PXAIPL", 9,0) Q:'$L ($T(^GMPLU TL))"RTN", "PXAIPL",1 0,0) ;"RTN ","PXAIPL" ,11,0) N P XARRAY,RES ULT"RTN"," PXAIPL",12 ,0)DECIDE  ;--DECIDE  IF A PROBL EM"RTN","P XAIPL",13, 0) I $G(PX AA("PL ADD "))=1 G SE T"RTN","PX AIPL",14,0 ) I $G(PXA A("PL IEN" ))>0 G SET "RTN","PXA IPL",15,0)  I $G(PXAA ("PL ACTIV E"))]"" G  SET"RTN"," PXAIPL",16 ,0) I $G(P XAA("PL ON SET DATE") )>0 G SET" RTN","PXAI PL",17,0)  I $G(PXAA( "PL RESOLV ED DATE")) >0 G SET"R TN","PXAIP L",18,0) ; PX*1.0*124 "RTN","PXA IPL",19,0)  ;I $G(PXA A("PL SC") )]"" G SET "RTN","PXA IPL",20,0)  ;I $G(PXA A("PL AO") )]"" G SET "RTN","PXA IPL",21,0)  ;I $G(PXA A("PL IR") )]"" G SET "RTN","PXA IPL",22,0)  ;I $G(PXA A("PL EC") )]"" G SET "RTN","PXA IPL",23,0)  ;I $G(PXA A("PL MST" ))]"" G SE T"RTN","PX AIPL",24,0 ) ;I $G(PX AA("PL HNC "))]"" G S ET"RTN","P XAIPL",25, 0) ;I $G(P XAA("PL CV "))]"" G S ET"RTN","P XAIPL",26, 0) ;I $G(P XAA("PL SH AD"))]"" G  SET"RTN", "PXAIPL",2 7,0) ;  dj s  PX*1.0* 207  RSD S PEC# 2.6.2 .1.1  Adde d comment  for Camp L ejeune Ind . in line  with previ ous commen ts"RTN","P XAIPL",28, 0) ;I $G(P XAA("PL CL V"))]"" G  SET"RTN"," PXAIPL",29 ,0) Q"RTN" ,"PXAIPL", 30,0) ;"RT N","PXAIPL ",31,0) ;" RTN","PXAI PL",32,0)S ET ;--REQU IRED"RTN", "PXAIPL",3 3,0) S PXA RRAY("PATI ENT")=$G(P ATIENT)"RT N","PXAIPL ",34,0) S  PXARRAY("N ARRATIVE") =$G(PXAA(" NARRATIVE" ))"RTN","P XAIPL",35, 0) S PXARR AY("PROVID ER")=$G(PX AA("ENC PR OVIDER"))" RTN","PXAI PL",36,0)  ;--OPTIONA L"RTN","PX AIPL",37,0 ) S PXARRA Y("DIAGNOS IS")=$G(PX AA("DIAGNO SIS"))"RTN ","PXAIPL" ,38,0) S P XARRAY("DX _DATE_OF_I NTEREST")= $$CSDATE^P XDXUTL(PXA VISIT)"RTN ","PXAIPL" ,39,0) S P XARRAY("LE XICON")=$G (PXAA("LEX ICON TERM" ))"RTN","P XAIPL",40, 0) S PXARR AY("STATUS ")=$G(PXAA ("PL ACTIV E"))"RTN", "PXAIPL",4 1,0) S PXA RRAY("ONSE T")=$G(PXA A("PL ONSE T DATE"))" RTN","PXAI PL",42,0)  I '$G(PXAA ("PL IEN") ) S PXARRA Y("RECORDE D")=$G(PXA A("EVENT D /T"))"RTN" ,"PXAIPL", 43,0) S PX ARRAY("RES OLVED")=$G (PXAA("PL  RESOLVED D ATE"))"RTN ","PXAIPL" ,44,0) S P XARRAY("CO MMENT")=$G (PXAA("COM MENT"))"RT N","PXAIPL ",45,0) I  $G(PXARRAY ("COMMENT" ))="@" S P XARRAY("CO MMENT")="" "RTN","PXA IPL",46,0)  ;--LOCATI ON"RTN","P XAIPL",47, 0) S PXARR AY("LOCATI ON")=$P($G (^AUPNVSIT (PXAVISIT, 0)),"^",22 )"RTN","PX AIPL",48,0 ) ;--SERVI CE CONNECT EDNESS"RTN ","PXAIPL" ,49,0) S P XARRAY("SC ")=$P(AFTE R800,"^",1 )"RTN","PX AIPL",50,0 ) S PXARRA Y("AO")=$P (AFTER800, "^",2)"RTN ","PXAIPL" ,51,0) S P XARRAY("IR ")=$P(AFTE R800,"^",3 )"RTN","PX AIPL",52,0 ) S PXARRA Y("EC")=$P (AFTER800, "^",4)"RTN ","PXAIPL" ,53,0) S P XARRAY("MS T")=$P(AFT ER800,"^", 5)"RTN","P XAIPL",54, 0) S PXARR AY("HNC")= $P(AFTER80 0,"^",6)"R TN","PXAIP L",55,0) S  PXARRAY(" CV")=$P(AF TER800,"^" ,7)"RTN"," PXAIPL",56 ,0) S PXAR RAY("SHAD" )=$P(AFTER 800,"^",8) "RTN","PXA IPL",57,0)  ;  djs  P X*1.0*207   RSD SPEC  #2.6.2.1.1   Set CL-V  piece #9  to value o f AFTER800  array #9" RTN","PXAI PL",58,0)  S PXARRAY( "CLV")=$P( AFTER800," ^",9)"RTN" ,"PXAIPL", 59,0) ;--- MISC"RTN", "PXAIPL",6 0,0) S PXA RRAY("PROB LEM")=$G(P XAA("PL IE N"))"RTN", "PXAIPL",6 1,0) ;"RTN ","PXAIPL" ,62,0) ;"R TN","PXAIP L",63,0) ; "RTN","PXA IPL",64,0) RUN ;"RTN" ,"PXAIPL", 65,0) D UP DATE^GMPLU TL(.PXARRA Y,.RESULT) "RTN","PXA IPL",66,0)  I RESULT( 0)="" S $P (AFTER0,"^ ",16)=RESU LT"RTN","P XAIPL",67, 0) ;--**SE T ERROR IN TO DIALOG" RTN","PXAI PL",68,0)  I RESULT(0 )]"" D"RTN ","PXAIPL" ,69,0) .S  PXAERR("PL 1")=$G(RES ULT(0))"RT N","PXAIPL ",70,0) .S  PXAERRF=1 "RTN","PXA IPL",71,0)  .S PXADI( "DIALOG")= 8390001.00 4"RTN","PX AIPL",72,0 ) Q"RTN"," PXAIPOV")0 ^4^B250053 98"RTN","P XAIPOV",1, 0)PXAIPOV  ;ISL/JVS,E SW - SET T HE DIAGNOS IS/PROBLEM  LIST NODE S ;6/25/03  2:05pm"RT N","PXAIPO V",2,0) ;; 1.0;PCE PA TIENT CARE  ENCOUNTER ;**28,73,6 9,108,112, 130,124,17 4,168,203, 199,207**; Aug 12, 19 96;Build 5 4"RTN","PX AIPOV",3,0 ) ;"RTN"," PXAIPOV",4 ,0) Q"RTN" ,"PXAIPOV" ,5,0)POV ; --CREATE D IAGNOSIS"R TN","PXAIP OV",6,0) ; "RTN","PXA IPOV",7,0) SET ;--SET  AND NEW V ARIABLES"R TN","PXAIP OV",8,0) N  AFTER0,AF TER12,AFTE R800,AFTER 801,AFTER8 02,AFTER81 1,AFTER812 ,AFTER8A"R TN","PXAIP OV",9,0) N  BEFOR0,BE FOR12,BEFO R800,BEFOR 801,BEFOR8 02,BEFOR81 1,BEFOR812 ,FPRI"RTN" ,"PXAIPOV" ,10,0) N G MPSAVED,IE NB,J,LNARR ,NOPLLIST, PIECE,POVI ,PRI,PRVDR ,PXAA,PXAA X,PXAB"RTN ","PXAIPOV ",11,0) N  PXAIVDT,PX BCNT,PXBCN TPL,PXBKY, PXBPMT,PXB SAM,PXBSKY ,PXDIGNS,P XKDONE"RTN ","PXAIPOV ",12,0) N  STOP,SUB,V AR"RTN","P XAIPOV",13 ,0) ;"RTN" ,"PXAIPOV" ,14,0) K P XAERR"RTN" ,"PXAIPOV" ,15,0) S P XAERR(8)=P XAK"RTN"," PXAIPOV",1 6,0) S PXA ERR(7)="DX /PL""RTN", "PXAIPOV", 17,0) ;"RT N","PXAIPO V",18,0) S  SUB="" F   S SUB=$O( @PXADATA@( "DX/PL",PX AK,SUB)) Q :SUB=""  D "RTN","PXA IPOV",19,0 ) .S PXAA( SUB)=@PXAD ATA@("DX/P L",PXAK,SU B)"RTN","P XAIPOV",20 ,0) ;"RTN" ,"PXAIPOV" ,21,0) ;-- VALIDATE E NOUGH DATA "RTN","PXA IPOV",22,0 ) D VAL^PX AIPOVV Q:$ G(STOP)"RT N","PXAIPO V",23,0) ; "RTN","PXA IPOV",24,0 )SETVARA ; --SET VISI T VARIABLE S"RTN","PX AIPOV",25, 0) S $P(AF TER0,"^",1 )=$G(PXAA( "DIAGNOSIS "))"RTN"," PXAIPOV",2 6,0) I $G( PXAA("DELE TE")) S $P (AFTER0,"^ ",1)="@""R TN","PXAIP OV",27,0)  S $P(AFTER 0,"^",2)=$ G(PATIENT) ,PXAA("PAT IENT")=$G( PATIENT)"R TN","PXAIP OV",28,0)  S $P(AFTER 0,"^",3)=$ G(PXAVISIT )"RTN","PX AIPOV",29, 0) S $P(AF TER0,"^",4 )=$G(PXAA( "NARRATIVE ")) D"RTN" ,"PXAIPOV" ,30,0) .I  $G(PXAA("N ARRATIVE") )']""!($L( $G(PXAA("N ARRATIVE") ))>245) D" RTN","PXAI POV",31,0)  .. S PXAI VDT=$S($L( $G(PXAVISI T)):$$CSDA TE^PXDXUTL (PXAVISIT) ,1:DT) ; g et visit d ate"RTN"," PXAIPOV",3 2,0) .. S  PXAA("NARR ATIVE")=$$ DXNARR^PXU TL1($G(PXA A("DIAGNOS IS")),PXAI VDT) ; use  diagnosis  descripti on if no n arrative o r narrativ e too long "RTN","PXA IPOV",33,0 ) .S $P(AF TER0,"^",4 )=+$$PROVN ARR^PXAPI( $G(PXAA("N ARRATIVE") ),9000010. 07)"RTN"," PXAIPOV",3 4,0) ;PX*1 *124"RTN", "PXAIPOV", 35,0) S $P (AFTER0,"^ ",12)=$S($ G(PXAA("PR IMARY"))=1 :"P",$G(PX AA("PRIMAR Y"))="P":" P",1:"S")" RTN","PXAI POV",36,0)  ;--ADDED  FOR PATCH  28"RTN","P XAIPOV",37 ,0) S $P(A FTER0,"^", 15)=$G(PXA A("LEXICON  TERM"))"R TN","PXAIP OV",38,0)  S $P(AFTER 0,"^",16)= $G(PXAA("P L IEN"))"R TN","PXAIP OV",39,0)  S $P(AFTER 0,"^",17)= $G(PXAA("O RD/RES"))" RTN","PXAI POV",40,0)  ;--END OF  NEW PATCH  28"RTN"," PXAIPOV",4 1,0) S $P( AFTER12,"^ ",1)=$G(PX AA("EVENT  D/T"))"RTN ","PXAIPOV ",42,0) S  $P(AFTER12 ,"^",4)=$G (PXAA("ENC  PROVIDER" ))"RTN","P XAIPOV",43 ,0) ;PX*1* 108"RTN"," PXAIPOV",4 4,0) I $G( PXAA("ENC  PROVIDER") )]"",'$G(P XAA("DELET E")) D"RTN ","PXAIPOV ",45,0) .S  ^TMP("PXA IADDPRV",$ J,$G(PXAA( "ENC PROVI DER")))="" "RTN","PXA IPOV",46,0 ) ;"RTN"," PXAIPOV",4 7,0) I $G( PXAA("CATE GORY"))]""  S $P(AFTE R802,"^",1 )=+$$PROVN ARR^PXAPI( $G(PXAA("C ATEGORY")) ,9000010.0 7)"RTN","P XAIPOV",48 ,0) S $P(A FTER811,"^ ",1)=$G(PX AA("COMMEN T"))"RTN", "PXAIPOV", 49,0) ;"RT N","PXAIPO V",50,0) S  $P(AFTER8 00,"^",1)= $G(PXAA("P L SC"))"RT N","PXAIPO V",51,0) S  $P(AFTER8 00,"^",2)= $G(PXAA("P L AO"))"RT N","PXAIPO V",52,0) S  $P(AFTER8 00,"^",3)= $G(PXAA("P L IR"))"RT N","PXAIPO V",53,0) S  $P(AFTER8 00,"^",4)= $G(PXAA("P L EC"))"RT N","PXAIPO V",54,0) S  $P(AFTER8 00,"^",5)= $G(PXAA("P L MST"))"R TN","PXAIP OV",55,0)  S $P(AFTER 800,"^",6) =$G(PXAA(" PL HNC"))" RTN","PXAI POV",56,0)  S $P(AFTE R800,"^",7 )=$G(PXAA( "PL CV"))" RTN","PXAI POV",57,0)  S $P(AFTE R800,"^",8 )=$G(PXAA( "PL SHAD") )"RTN","PX AIPOV",58, 0) ;  djs   PX*1.0*20 7  RSD SPE C #2.6.2.1 .1  Set AF TER800 arr ay #9 to v alue of CL -V piece # 9"RTN","PX AIPOV",59, 0) S $P(AF TER800,"^" ,9)=$G(PXA A("PL CLV" ))"RTN","P XAIPOV",60 ,0) ;"RTN" ,"PXAIPOV" ,61,0) D S CC^PXUTLSC C(PATIENT, $P($G(^AUP NVSIT(PXAV ISIT,0))," ^",1),$P($ G(^AUPNVSI T(PXAVISIT ,0)),"^",2 2),$G(PXAV ISIT),AFTE R800,.AFTE R800)"RTN" ,"PXAIPOV" ,62,0) ;"R TN","PXAIP OV",63,0)  I $G(PXAA( "PL SC"))= "" S $P(AF TER800,"^" ,1)="""RTN ","PXAIPOV ",64,0) I  $G(PXAA("P L AO"))=""  S $P(AFTE R800,"^",2 )="""RTN", "PXAIPOV", 65,0) I $G (PXAA("PL  IR"))="" S  $P(AFTER8 00,"^",3)= """RTN","P XAIPOV",66 ,0) I $G(P XAA("PL EC "))="" S $ P(AFTER800 ,"^",4)="" "RTN","PXA IPOV",67,0 ) I $G(PXA A("PL MST" ))="" S $P (AFTER800, "^",5)=""" RTN","PXAI POV",68,0)  I $G(PXAA ("PL HNC") )="" S $P( AFTER800," ^",6)="""R TN","PXAIP OV",69,0)  I $G(PXAA( "PL CV"))= "" S $P(AF TER800,"^" ,7)="""RTN ","PXAIPOV ",70,0) I  $G(PXAA("P L SHAD"))= "" S $P(AF TER800,"^" ,8)="""RTN ","PXAIPOV ",71,0) ;   djs  PX*1 .0*207  RS D SPEC #2. 6.2.1.1  I f CL-V pie ce #9="",  set AFTER8 00 array p iece #9=""   "RTN","P XAIPOV",72 ,0) I $G(P XAA("PL CL V"))="" S  $P(AFTER80 0,"^",9)=" ""RTN","PX AIPOV",73, 0) ;"RTN", "PXAIPOV", 74,0) S $P (AFTER812, "^",3)=$G( PXASOURC)" RTN","PXAI POV",75,0)  S $P(AFTE R812,"^",2 )=$G(PXAPK G)"RTN","P XAIPOV",76 ,0) ;"RTN" ,"PXAIPOV" ,77,0) D P L^PXAIPL"R TN","PXAIP OV",78,0)  ;"RTN","PX AIPOV",79, 0) ;"RTN", "PXAIPOV", 80,0)SETPX KA ;--SET  PXK ARRAY  AFTER"RTN" ,"PXAIPOV" ,81,0) S ^ TMP("PXK", $J,"POV",P XAK,0,"AFT ER")=$G(AF TER0)"RTN" ,"PXAIPOV" ,82,0) S ^ TMP("PXK", $J,"POV",P XAK,12,"AF TER")=$G(A FTER12)"RT N","PXAIPO V",83,0) S  ^TMP("PXK ",$J,"POV" ,PXAK,800, "AFTER")=$ G(AFTER800 )"RTN","PX AIPOV",84, 0) S ^TMP( "PXK",$J," POV",PXAK, 802,"AFTER ")=$G(AFTE R802)"RTN" ,"PXAIPOV" ,85,0) S ^ TMP("PXK", $J,"POV",P XAK,811,"A FTER")=$G( AFTER811)" RTN","PXAI POV",86,0)  S ^TMP("P XK",$J,"PO V",PXAK,81 2,"AFTER") =$G(AFTER8 12)"RTN"," PXAIPOV",8 7,0) ;"RTN ","PXAIPOV ",88,0)SET VARB ;--SE T VARIABLE S BEFORE"R TN","PXAIP OV",89,0)  ;"RTN","PX AIPOV",90, 0) ;--GET  IEN FOR 'P XK NODE'"R TN","PXAIP OV",91,0)  D POV^PXBG POV(PXAVIS IT)"RTN"," PXAIPOV",9 2,0) I $D( ^TMP("PXBG POVMATCH", $J,$G(PXAA ("DIAGNOSI S")))) D"R TN","PXAIP OV",93,0)  .S (^TMP(" PXK",$J,"P OV",PXAK," IEN"),IENB )=$O(^TMP( "PXBGPOVMA TCH",$J,$G (PXAA("DIA GNOSIS")), 0))"RTN"," PXAIPOV",9 4,0) K ^TM P("PXBGPOV MATCH",$J) "RTN","PXA IPOV",95,0 ) ;"RTN"," PXAIPOV",9 6,0)BEFOR  ;"RTN","PX AIPOV",97, 0) I $G(IE NB) D"RTN" ,"PXAIPOV" ,98,0) .F  PIECE=0,12 ,800,802,8 11 S ^TMP( "PXK",$J," POV",PXAK, PIECE,"BEF ORE")=$G(^ AUPNVPOV(I ENB,PIECE) )"RTN","PX AIPOV",99, 0) .K ^TMP ("PXK",$J, "POV",PXAK ,812)"RTN" ,"PXAIPOV" ,100,0) E   D"RTN","P XAIPOV",10 1,0) .S (B EFOR0,BEFO R12,BEFOR8 00,BEFOR80 2,BEFOR811 ,BEFOR812) ="""RTN"," PXAIPOV",1 02,0) .;"R TN","PXAIP OV",103,0) SETPXKB .; --SET PXK  ARRAY BEFO RE"RTN","P XAIPOV",10 4,0) .S ^T MP("PXK",$ J,"POV",PX AK,0,"BEFO RE")=$G(BE FOR0)"RTN" ,"PXAIPOV" ,105,0) .S  ^TMP("PXK ",$J,"POV" ,PXAK,12," BEFORE")=$ G(BEFOR12) "RTN","PXA IPOV",106, 0) .S ^TMP ("PXK",$J, "POV",PXAK ,800,"BEFO RE")=$G(BE FOR800)"RT N","PXAIPO V",107,0)  .S ^TMP("P XK",$J,"PO V",PXAK,80 2,"BEFORE" )=$G(BEFOR 802)"RTN", "PXAIPOV", 108,0) .S  ^TMP("PXK" ,$J,"POV", PXAK,811," BEFORE")=$ G(BEFOR811 )"RTN","PX AIPOV",109 ,0) .S ^TM P("PXK",$J ,"POV",PXA K,812,"BEF ORE")=$G(B EFOR812)"R TN","PXAIP OV",110,0)  .S ^TMP(" PXK",$J,"P OV",PXAK," IEN")="""R TN","PXAIP OV",111,0)  ;"RTN","P XAIPOV",11 2,0)MISC ; --MISCELLA NEOUS NODE "RTN","PXA IPOV",113, 0) ;"RTN", "PXAIPOV", 114,0) Q"R TN","PXAIP OV",115,0) PRIM ;--SE T A PROVID ER AS PRIM ARY"RTN"," PXAIPOV",1 16,0) N PX BCNT,PXBKY ,PXBSAM,PX BSKY,PRVDR ,FPRI ;108 "RTN","PXA IPOV",117, 0) D PRV^P XBGPRV(PXA VISIT,.PXB SKY,.PXBKY ,.PXBSAM,. PXBCNT,.PR VDR,.FPRI)  ;108"RTN" ,"PXAIPOV" ,118,0) I  $D(PRVDR)  Q"RTN","PX AIPOV",119 ,0) I '$D( PXBSKY) Q" RTN","PXAI POV",120,0 ) ;"RTN"," PXAIPOV",1 21,0) S $P (AFTER0,"^ ",1)=$P(^A UPNVPRV($O (PXBSKY(1, 0)),0),"^" ,1)"RTN"," PXAIPOV",1 22,0) S $P (AFTER0,"^ ",2)=$P(^A UPNVSIT(PX AVISIT,0), "^",5)"RTN ","PXAIPOV ",123,0) S  $P(AFTER0 ,"^",3)=PX AVISIT"RTN ","PXAIPOV ",124,0) S  $P(AFTER0 ,"^",4)="P ""RTN","PX AIPOV",125 ,0) S ^TMP ("PXK",$J, "PRV",2222 2,0,"AFTER ")=AFTER0" RTN","PXAI POV",126,0 ) S ^TMP(" PXK",$J,"P RV",22222, 0,"BEFORE" )=$G(^AUPN VPRV($O(PX BSKY(1,0)) ,0))"RTN", "PXAIPOV", 127,0) S ^ TMP("PXK", $J,"PRV",2 2222,"IEN" )=$O(PXBSK Y(1,0))"RT N","PXAIPO V",128,0)  D EN1^PXKM AIN"RTN"," PXAIPOV",1 29,0) K PX RDR"RTN"," PXAIPOV",1 30,0) K ^T MP("PXBGPO VMATCH",$J )"RTN","PX AIPOV",131 ,0) Q"RTN" ,"PXAIVST" )0^5^B1653 0572"RTN", "PXAIVST", 1,0)PXAIVS T ;ISL/JVS ,KWP,ESW -  GET A VIS IT FROM EN COUNTER NO DE ;11/20/ 02 4:38pm" RTN","PXAI VST",2,0)  ;;1.0;PCE  PATIENT CA RE ENCOUNT ER;**5,9,1 5,74,111,9 6,130,124, 164,168,20 7**;Aug 12 , 1996;Bui ld 54"RTN" ,"PXAIVST" ,3,0) ;"RT N","PXAIVS T",4,0) ;" RTN","PXAI VST",5,0)  Q"RTN","PX AIVST",6,0 )VST ;--CR EAT A VISI T"RTN","PX AIVST",7,0 ) ;"RTN"," PXAIVST",8 ,0)SET ;-- SET AND NE W VARIABLE S"RTN","PX AIVST",9,0 ) N AFTER0 ,AFTER21,A FTER800,AF TER150,BEF OR0,BEFOR2 1,BEFOR800 ,BEFOR150" RTN","PXAI VST",10,0)  N AFTER81 1,BEFOR811 ,BEFOR812" RTN","PXAI VST",11,0)  N PXAA,PX AB,SUB,PIE CE,STOP"RT N","PXAIVS T",12,0) N  AFTER8A,A FTER812"RT N","PXAIVS T",13,0) ; "RTN","PXA IVST",14,0 ) S SUB=""  F  S SUB= $O(@PXADAT A@("ENCOUN TER",1,SUB )) Q:SUB=" "  D"RTN", "PXAIVST", 15,0) .S P XAA(SUB)=@ PXADATA@(" ENCOUNTER" ,1,SUB)"RT N","PXAIVS T",16,0) ; "RTN","PXA IVST",17,0 ) S (AFTER 812,BEFOR8 12)="""RTN ","PXAIVST ",18,0) ;" RTN","PXAI VST",19,0)  S PXAK=1" RTN","PXAI VST",20,0)  S PXAERR( 8)=1"RTN", "PXAIVST", 21,0) S PX AERR(7)="E NCOUNTER"" RTN","PXAI VST",22,0)  ;"RTN","P XAIVST",23 ,0)VAL ;-- VALIDATE E NOUGH DATA "RTN","PXA IVST",24,0 ) I $D(@PX ADATA@("EN COUNTER"))  D VAL^PXA IVSTV Q:$G (STOP)"RTN ","PXAIVST ",25,0) I  $G(PXAVISI T) S (PATI ENT,PXAA(" PATIENT")) =$P(^AUPNV SIT(PXAVIS IT,0),"^", 5) S PXAA( "ENC D/T") =$P(^AUPNV SIT(PXAVIS IT,0),"^", 1) S PXAA( "HOS LOC") =$P(^AUPNV SIT(PXAVIS IT,0),"^", 22)"RTN"," PXAIVST",2 6,0) ;"RTN ","PXAIVST ",27,0)SET VARA ;--SE T VISIT VA RIABLES"RT N","PXAIVS T",28,0) S  $P(AFTER0 ,"^",1)=$G (PXAA("ENC  D/T"))"RT N","PXAIVS T",29,0) ; PX*1*96 -  Set TYPE ( Piece #3)  according  to followi ng;"RTN"," PXAIVST",3 0,0) ; 1.  If OUTSIDE  LOCATION  then TYPE  is "O""RTN ","PXAIVST ",31,0) ;  2. If no O UTSIDE LOC ATION but  INSTITUTIO N then TYP E is "V""R TN","PXAIV ST",32,0)  ; 3. Else  set to val ue of DUZ( "AG")"RTN" ,"PXAIVST" ,33,0) ;Se t TYPE"RTN ","PXAIVST ",34,0) I  $L($G(PXAA ("OUTSIDE  LOCATION") )) S $P(AF TER0,U,3)= "O""RTN"," PXAIVST",3 5,0) E  I  $L($G(PXAA ("INSTITUT ION"))) S  $P(AFTER0, U,3)="V""R TN","PXAIV ST",36,0)  E  S $P(AF TER0,U,3)= $G(DUZ("AG "))"RTN"," PXAIVST",3 7,0) S $P( AFTER0,"^" ,5)=$G(PXA A("PATIENT "))"RTN"," PXAIVST",3 8,0) S $P( AFTER0,"^" ,6)=$G(PXA A("INSTITU TION"))"RT N","PXAIVS T",39,0) S  $P(AFTER0 ,"^",7)=$G (PXAA("SER VICE CATEG ORY"))"RTN ","PXAIVST ",40,0) S  $P(AFTER0, "^",8)=""  ;$G(PXAA(" DSS ID"))" RTN","PXAI VST",41,0)  S $P(AFTE R0,"^",12) =$G(PXAA(" PARENT"))" RTN","PXAI VST",42,0)  S $P(AFTE R0,"^",18) =$G(PXAA(" CHECKOUT D /T"))"RTN" ,"PXAIVST" ,43,0) S $ P(AFTER0," ^",21)=$G( PXAA("ELIG IBILITY")) "RTN","PXA IVST",44,0 ) S $P(AFT ER0,"^",26 )=$S($G(PX ACCNT)>0:$ G(PXACCNT) ,1:"") ;PX *1.0*164"R TN","PXAIV ST",45,0)  S $P(PXELA P,"^",1)=$ G(PXAA("EL IGIBILITY" ))"RTN","P XAIVST",46 ,0) S $P(P XELAP,"^", 3)=$G(PXAA ("APPT"))" RTN","PXAI VST",47,0)  S $P(AFTE R0,"^",22) =$G(PXAA(" HOS LOC")) "RTN","PXA IVST",48,0 ) S $P(AFT ER800,"^", 1)=$G(PXAA ("SC"))"RT N","PXAIVS T",49,0) S  $P(AFTER8 00,"^",2)= $G(PXAA("A O"))"RTN", "PXAIVST", 50,0) S $P (AFTER800, "^",3)=$G( PXAA("IR") )"RTN","PX AIVST",51, 0) S $P(AF TER800,"^" ,4)=$G(PXA A("EC"))"R TN","PXAIV ST",52,0)  S $P(AFTER 800,"^",5) =$G(PXAA(" MST"))"RTN ","PXAIVST ",53,0) ;P X*1*111 -  Add HNC"RT N","PXAIVS T",54,0) S  $P(AFTER8 00,"^",6)= $G(PXAA("H NC"))"RTN" ,"PXAIVST" ,55,0) S $ P(AFTER800 ,"^",7)=$G (PXAA("CV" ))"RTN","P XAIVST",56 ,0) S $P(A FTER800,"^ ",8)=$G(PX AA("SHAD") )"RTN","PX AIVST",57, 0) ;  djs   PX*1.0*20 7  RSD SPE C #2.6.2.4 .1.1  Set  AFTER800 a rray piece  #9 to val ue of CL-V  piece #9" RTN","PXAI VST",58,0)  S $P(AFTE R800,"^",9 )=$G(PXAA( "CLV"))"RT N","PXAIVS T",59,0) ; "RTN","PXA IVST",60,0 ) ;--VALID ATE SERVIC E CONNECTE DNESS"RTN" ,"PXAIVST" ,61,0) ;"R TN","PXAIV ST",62,0)  S AFTER8A= AFTER800 D  VALSCC^PX AIVSTV"RTN ","PXAIVST ",63,0) S  AFTER800=A FTER8A"RTN ","PXAIVST ",64,0) ;" RTN","PXAI VST",65,0)  S $P(AFTE R21,"^",1) =$G(PXAA(" OUTSIDE LO CATION"))  ;PX/96"RTN ","PXAIVST ",66,0) S  $P(AFTER15 0,"^",3)=$ G(PXAA("EN COUNTER TY PE"))"RTN" ,"PXAIVST" ,67,0) S $ P(AFTER811 ,"^",1)=$G (PXAA("COM MENT"))"RT N","PXAIVS T",68,0) S  $P(AFTER8 12,"^",3)= $G(PXASOUR C)"RTN","P XAIVST",69 ,0)SETPXKA  ;--SET PX K ARRAY AF TER"RTN"," PXAIVST",7 0,0) S ^TM P("PXK",$J ,"VST",1,0 ,"AFTER")= AFTER0"RTN ","PXAIVST ",71,0) S  ^TMP("PXK" ,$J,"VST", 1,21,"AFTE R")=AFTER2 1"RTN","PX AIVST",72, 0) S ^TMP( "PXK",$J," VST",1,150 ,"AFTER")= AFTER150"R TN","PXAIV ST",73,0)  S ^TMP("PX K",$J,"VST ",1,800,"A FTER")=AFT ER800"RTN" ,"PXAIVST" ,74,0) S ^ TMP("PXK", $J,"VST",1 ,811,"AFTE R")=AFTER8 11"RTN","P XAIVST",75 ,0) S ^TMP ("PXK",$J, "VST",1,81 2,"AFTER") =AFTER812" RTN","PXAI VST",76,0) SETVARB ;- -SET VARIA BLES BEFOR E"RTN","PX AIVST",77, 0) I $G(PX AVISIT) D" RTN","PXAI VST",78,0)  .F PIECE= 0,21,150,8 00,811,812  S ^TMP("P XK",$J,"VS T",1,PIECE ,"BEFORE") =$G(^AUPNV SIT(PXAVIS IT,PIECE)) "RTN","PXA IVST",79,0 ) .I '$D(@ PXADATA@(" ENCOUNTER" )) D"RTN", "PXAIVST", 80,0) ..F  PIECE=0,21 ,150,800,8 11,812 S ^ TMP("PXK", $J,"VST",1 ,PIECE,"AF TER")=$G(^ AUPNVSIT(P XAVISIT,PI ECE))"RTN" ,"PXAIVST" ,81,0) E   D"RTN","PX AIVST",82, 0) .S (BEF OR0,BEFOR2 1,BEFOR150 ,BEFOR800, BEFOR811)= """RTN","P XAIVST",83 ,0) .;"RTN ","PXAIVST ",84,0)SET PXKB .;--S ET PXK ARR AY BEFORE" RTN","PXAI VST",85,0)  .S ^TMP(" PXK",$J,"V ST",1,0,"B EFORE")=BE FOR0"RTN", "PXAIVST", 86,0) .S ^ TMP("PXK", $J,"VST",1 ,21,"BEFOR E")=BEFOR2 1"RTN","PX AIVST",87, 0) .S ^TMP ("PXK",$J, "VST",1,15 0,"BEFORE" )=BEFOR150 "RTN","PXA IVST",88,0 ) .S ^TMP( "PXK",$J," VST",1,800 ,"BEFORE") =BEFOR800" RTN","PXAI VST",89,0)  .S ^TMP(" PXK",$J,"V ST",1,811, "BEFORE")= BEFOR811"R TN","PXAIV ST",90,0)  .S ^TMP("P XK",$J,"VS T",1,812," BEFORE")=B EFOR812"RT N","PXAIVS T",91,0)MI SC ;--MISC ELLANEOUS  NODE"RTN", "PXAIVST", 92,0) S ^T MP("PXK",$ J,"VST",1, "IEN")=$G( PXAVISIT)" RTN","PXAI VST",93,0)  ;"RTN","P XAIVST",94 ,0)CALL ;- -CALL"RTN" ,"PXAIVST" ,95,0) S P XALOOK=$$L OOKVSIT^PX UTLVST($P( AFTER0,U,5 ),$P(AFTER 0,U),$P(AF TER0,U,22) ,$P(AFTER0 ,"^",8),$P (AFTER0,U, 6)) I $G(P XALOOK)>0  S PXAVISIT =PXALOOK ; PX/96 - in cluded INS TITUTION -  $P(AFTER0 ,U,6)"RTN" ,"PXAIVST" ,96,0) D E N1^PXKMAIN "RTN","PXA IVST",97,0 ) I '$G(PX AVISIT) S  PXAVISIT=$ G(^TMP("PX K",$J,"VST ",1,"IEN") )"RTN","PX AIVST",98, 0) Q"RTN", "PXAIVSTV" )0^29^B640 68519"RTN" ,"PXAIVSTV ",1,0)PXAI VSTV ;ISL/ JVS,ISA/KW P - VALIDA TE THE VIS IT DATA ;4 /23/04 11: 54am"RTN", "PXAIVSTV" ,2,0) ;;1. 0;PCE PATI ENT CARE E NCOUNTER;* *9,15,19,7 4,111,116, 130,124,16 8,207**;Au g 12, 1996 ;Build 54" RTN","PXAI VSTV",3,0)  ;"RTN","P XAIVSTV",4 ,0) ;"RTN" ,"PXAIVSTV ",5,0) Q"R TN","PXAIV STV",6,0)V ALSCC ;--V ALIDATE SE RVICE CONN ECTIVENESS "RTN","PXA IVSTV",7,0 ) N ERR,ER R1"RTN","P XAIVSTV",8 ,0) D SCC^ PXUTLSCC($ G(PXAA("PA TIENT")),$ G(PXAA("EN C D/T")),$ G(PXAA("HO S LOC")),$ G(PXAVISIT ),$G(AFTER 800),.AFTE R8A,.ERR)" RTN","PXAI VSTV",9,0)  ;PX*1*111  - Add HNC "RTN","PXA IVSTV",10, 0) ;  djs   PX*1.0*20 7  RSD SPE C # 2.6.2. 4.1.1  Add  check for  piece #9,  Camp Leje une"RTN"," PXAIVSTV", 11,0) I $P (ERR,"^",1 )=0,$P(ERR ,"^",2)=0, $P(ERR,"^" ,3)=0,$P(E RR,"^",4)= 0,$P(ERR," ^",5)=0,$P (ERR,"^",6 )=0,$P(ERR ,"^",7)=0, $P(ERR,"^" ,8)=0,$P(E RR,"^",9)= 0 Q"RTN"," PXAIVSTV", 12,0) S PX ADI("DIALO G")=839000 1.003"RTN" ,"PXAIVSTV ",13,0) S  PXAERRF=1" RTN","PXAI VSTV",14,0 ) S PXAERR ("1W")=$S( $P(AFTER80 0,"^",1)'] "":"NULL", 1:$P(AFTER 800,"^",1) )"RTN","PX AIVSTV",15 ,0) S PXAE RR("2W")=$ S($P(AFTER 800,"^",2) ']"":"NULL ",1:$P(AFT ER800,"^", 2))"RTN"," PXAIVSTV", 16,0) S PX AERR("3W") =$S($P(AFT ER800,"^", 3)']"":"NU LL",1:$P(A FTER800,"^ ",3))"RTN" ,"PXAIVSTV ",17,0) S  PXAERR("4W ")=$S($P(A FTER800,"^ ",4)']"":" NULL",1:$P (AFTER800, "^",4))"RT N","PXAIVS TV",18,0)  S PXAERR(" 5W")=$S($P (AFTER800, "^",5)']"" :"NULL",1: $P(AFTER80 0,"^",5))" RTN","PXAI VSTV",19,0 ) ;PX*1*11 1 - Add HN C"RTN","PX AIVSTV",20 ,0) S PXAE RR("16W")= $S($P(AFTE R800,"^",6 )']"":"NUL L",1:$P(AF TER800,"^" ,6))"RTN", "PXAIVSTV" ,21,0) S P XAERR("19W ")=$S($P(A FTER800,"^ ",7)']"":" NULL",1:$P (AFTER800, "^",7))"RT N","PXAIVS TV",22,0)  S PXAERR(" 22W")=$S($ P(AFTER800 ,"^",8)']" ":"NULL",1 :$P(AFTER8 00,"^",8)) "RTN","PXA IVSTV",23, 0) ;  djs   PX*1.0*20 7  RSD SPE C # 2.6.2. 4.1.1  Add  item to e rror array  for Camp  Lejeune"RT N","PXAIVS TV",24,0)  S PXAERR(" 25W")=$S($ P(AFTER800 ,"^",9)']" ":"NULL",1 :$P(AFTER8 00,"^",9)) "RTN","PXA IVSTV",25, 0) S ERR1= $P(ERR,"^" ,1),PXAERR ("6W")=$S( ERR1=1:"Sh ould be a  YES or NO! , not NULL ",ERR1=0:" No error", ERR1=-1:"N ot a valid  value",ER R1=-2:"Val ue must be  NULL",ERR 1=-3:"Must  be NULL b ecause Ser vice Conne cted is ye s",1:"")"R TN","PXAIV STV",26,0)  S ERR1=$P (ERR,"^",2 ),PXAERR(" 7W")=$S(ER R1=1:"Shou ld be a YE S or NO!,  not NULL", ERR1=0:"No  error",ER R1=-1:"Not  a valid v alue",ERR1 =-2:"Value  must be N ULL",ERR1= -3:"Must b e NULL bec ause Servi ce Connect ed is yes" ,1:"")"RTN ","PXAIVST V",27,0) S  ERR1=$P(E RR,"^",3), PXAERR("8W ")=$S(ERR1 =1:"Should  be a YES  or NO!, no t NULL",ER R1=0:"No e rror",ERR1 =-1:"Not a  valid val ue",ERR1=- 2:"Value m ust be NUL L",ERR1=-3 :"Must be  NULL becau se Service  Connected  is yes",1 :"")"RTN", "PXAIVSTV" ,28,0) S E RR1=$P(ERR ,"^",4),PX AERR("9W") =$S(ERR1=1 :"Should b e a YES or  NO!, not  NULL",ERR1 =0:"No err or",ERR1=- 1:"Not a v alid value ",ERR1=-2: "Value mus t be NULL" ,ERR1=-3:" Must be NU LL because  Service C onnected i s yes",1:" ")"RTN","P XAIVSTV",2 9,0) S ERR 1=$P(ERR," ^",5),PXAE RR("10W")= $S(ERR1=1: "Should be  a YES or  NO!, not N ULL",ERR1= 0:"No erro r",ERR1=-1 :"Not a va lid value" ,ERR1=-2:" Value must  be NULL", ERR1=-3:"M ust be NUL L because  Service Co nnected is  yes",1:"" )"RTN","PX AIVSTV",30 ,0) ;PX*1* 111 - Add  HNC"RTN"," PXAIVSTV", 31,0) S ER R1=$P(ERR, "^",6),PXA ERR("17W") =$S(ERR1=1 :"Should b e a YES or  NO!, not  NULL",ERR1 =0:"No err or",ERR1=- 1:"Not a v alid value ",ERR1=-2: "Value mus t be NULL" ,ERR1=-3:" Must be NU LL because  Service C onnected i s yes",1:" ")"RTN","P XAIVSTV",3 2,0) S ERR 1=$P(ERR," ^",7),PXAE RR("20W")= $S(ERR1=1: "Should be  a YES or  NO!, not N ULL",ERR1= 0:"No erro r",ERR1=-1 :"Not a va lid value" ,ERR1=-2:" Value must  be NULL", ERR1=-3:"M ust be NUL L because  Service Co nnected is  yes",1:"" )"RTN","PX AIVSTV",33 ,0) S ERR1 =$P(ERR,"^ ",8),PXAER R("23W")=$ S(ERR1=1:" Should be  a YES or N O!, not NU LL",ERR1=0 :"No error ",ERR1=-1: "Not a val id value", ERR1=-2:"V alue must  be NULL",E RR1=-3:"Mu st be NULL  because S ervice Con nected is  yes",1:"") "RTN","PXA IVSTV",34, 0) ;  djs   PX*1.0*20 7  RSD SPE C # 2.6.2. 4.1.1  Add  item to e rror array  for Camp  Lejeune"RT N","PXAIVS TV",35,0)  S ERR1=$P( ERR,"^",9) ,PXAERR("2 6W")=$S(ER R1=1:"Shou ld be a YE S or NO!,  not NULL", ERR1=0:"No  error",ER R1=-1:"Not  a valid v alue",ERR1 =-2:"Value  must be N ULL",ERR1= -3:"Must b e NULL bec ause Servi ce Connect ed is yes" ,1:"")"RTN ","PXAIVST V",36,0) S  PXAERR("1 1W")=$S($P (AFTER8A," ^",1)']"": "NULL",1:$ P(AFTER8A, "^",1))"RT N","PXAIVS TV",37,0)  S PXAERR(" 12W")=$S($ P(AFTER8A, "^",2)']"" :"NULL",1: $P(AFTER8A ,"^",2))"R TN","PXAIV STV",38,0)  S PXAERR( "13W")=$S( $P(AFTER8A ,"^",3)']" ":"NULL",1 :$P(AFTER8 A,"^",3))" RTN","PXAI VSTV",39,0 ) S PXAERR ("14W")=$S ($P(AFTER8 A,"^",4)'] "":"NULL", 1:$P(AFTER 8A,"^",4)) "RTN","PXA IVSTV",40, 0) S PXAER R("15W")=$ S($P(AFTER 8A,"^",5)' ]"":"NULL" ,1:$P(AFTE R8A,"^",5) )"RTN","PX AIVSTV",41 ,0) ;PX*1* 111 - Add  HNC"RTN"," PXAIVSTV", 42,0) S PX AERR("18W" )=$S($P(AF TER8A,"^", 6)']"":"NU LL",1:$P(A FTER8A,"^" ,6))"RTN", "PXAIVSTV" ,43,0) S P XAERR("21W ")=$S($P(A FTER8A,"^" ,7)']"":"N ULL",1:$P( AFTER8A,"^ ",7))"RTN" ,"PXAIVSTV ",44,0) S  PXAERR("24 W")=$S($P( AFTER8A,"^ ",8)']"":" NULL",1:$P (AFTER8A," ^",8))"RTN ","PXAIVST V",45,0) ;   djs  PX* 1.0*207  R SD SPEC #  2.6.2.4.1. 1  Add ite m to error  array for  Camp Leje une"RTN"," PXAIVSTV", 46,0) S PX AERR("27W" )=$S($P(AF TER8A,"^", 9)']"":"NU LL",1:$P(A FTER8A,"^" ,9))"RTN", "PXAIVSTV" ,47,0) D E RR^PXAI K  PXAERRF"RT N","PXAIVS TV",48,0)  Q"RTN","PX AIVSTV",49 ,0) ;"RTN" ,"PXAIVSTV ",50,0)VAL  ;--VALIDA TE ENOUGH  DATA"RTN", "PXAIVSTV" ,51,0) ;"R TN","PXAIV STV",52,0)  ;---Is th e visit se nt TO US v alid?"RTN" ,"PXAIVSTV ",53,0) I  $G(PXAVISI T) D  Q:$D (STOP)"RTN ","PXAIVST V",54,0) . I '$D(^AUP NVSIT(PXAV ISIT,0)) D   Q:$G(STO P)"RTN","P XAIVSTV",5 5,0) ..S S TOP=1"RTN" ,"PXAIVSTV ",56,0) .. S PXAERRF= 1"RTN","PX AIVSTV",57 ,0) ..S PX ADI("DIALO G")=839000 1.001"RTN" ,"PXAIVSTV ",58,0) .. S PXAERR(1 1)=$G(PXAV ISIT)"RTN" ,"PXAIVSTV ",59,0) .. S PXAERR(1 2)="The va lue that w as sent to  us is not  a valid v isit in th e VISIT fi le # 90000 10. The Pa tients nam e will be  derived fr om the vis it file an d could ca use the da ta to be g iven to th e wrong pa tient if n ot correct .""RTN","P XAIVSTV",6 0,0) ..S P XAERR(13)= "If the co rrect VISI T isn't kn own, set t he 'ENCOUN TER' array  and we wi ll look it  up or cre ate a corr ect one. S etting bot h at the s ame time w ill only a dd confusi on as to w hat data i s correct. ""RTN","PX AIVSTV",61 ,0) Q:$G(P XAVISIT)"R TN","PXAIV STV",62,0)  ;"RTN","P XAIVSTV",6 3,0) ;---- Missing a  date and t ime of vis it"RTN","P XAIVSTV",6 4,0) I $G( PXAA("ENC  D/T"))']""  D  Q:$G(S TOP)"RTN", "PXAIVSTV" ,65,0) .S  STOP=1 ;-- USED TO ST OP DO LOOP "RTN","PXA IVSTV",66, 0) .S PXAE RRF=1 ;--F LAG INDICA TES THERE  IS AN ERR" RTN","PXAI VSTV",67,0 ) .S PXADI ("DIALOG") =8390001.0 01"RTN","P XAIVSTV",6 8,0) .S PX AERR(9)="E NC D/T""RT N","PXAIVS TV",69,0)  .S PXAERR( 11)=$G(PXA A("ENC D/T "))"RTN"," PXAIVSTV", 70,0) .S P XAERR(12)= "You are m issing the  date and  time of th e visit in  FileManag er interna l format." "RTN","PXA IVSTV",71, 0) ;"RTN", "PXAIVSTV" ,72,0) ;-- --Missing  Time and n ot Histori cal Visit" RTN","PXAI VSTV",73,0 ) I $L($G( PXAA("ENC  D/T")),"." )=1,$G(PXA A("SERVICE  CATEGORY" ))'="E" D" RTN","PXAI VSTV",74,0 ) .S STOP= 1 ;--USED  TO STOP DO  LOOP"RTN" ,"PXAIVSTV ",75,0) .S  PXAERRF=1  ;--FLAG I NDICATES T HERE IS AN  ERR"RTN", "PXAIVSTV" ,76,0) .S  PXADI("DIA LOG")=8390 001.001"RT N","PXAIVS TV",77,0)  .S PXAERR( 9)="ENC D/ T""RTN","P XAIVSTV",7 8,0) .S PX AERR(11)=$ G(PXAA("EN C D/T"))"R TN","PXAIV STV",79,0)  .S PXAERR (12)="You  are missin g the TIME  of the vi sit in Fil eManager i nternal fo rmat. Unle ss this is  an HISTOR ICAL encou nter, you  must have  the time." "RTN","PXA IVSTV",80, 0) ;"RTN", "PXAIVSTV" ,81,0) ;"R TN","PXAIV STV",82,0)  ;"RTN","P XAIVSTV",8 3,0) ;---- MISSING a  pointer to  PATIENT/I HS FILE #  9000001"RT N","PXAIVS TV",84,0)  I $G(PXAA( "PATIENT") )']"" D  Q :$G(STOP)" RTN","PXAI VSTV",85,0 ) .S STOP= 1"RTN","PX AIVSTV",86 ,0) .S PXA ERRF=1"RTN ","PXAIVST V",87,0) . S PXADI("D IALOG")=83 90001.001" RTN","PXAI VSTV",88,0 ) .S PXAER R(9)="PATI ENT""RTN", "PXAIVSTV" ,89,0) .S  PXAERR(11) =$G(PXAA(" PATIENT")) "RTN","PXA IVSTV",90, 0) .S PXAE RR(12)="Mi ssing a po inter to t he PATIENT /IHS file  #9000001"" RTN","PXAI VSTV",91,0 ) ;"RTN"," PXAIVSTV", 92,0) ;"RT N","PXAIVS TV",93,0)  ;----Not a  pointer t o the PATI ENT/IHS fi le #900000 1"RTN","PX AIVSTV",94 ,0) I '$D( ^AUPNPAT($ G(PXAA("PA TIENT")),0 )) D  Q:$G (STOP)"RTN ","PXAIVST V",95,0) . S STOP=1"R TN","PXAIV STV",96,0)  .S PXAERR F=1"RTN"," PXAIVSTV", 97,0) .S P XADI("DIAL OG")=83900 01.001"RTN ","PXAIVST V",98,0) . S PXAERR(9 )="PATIENT ""RTN","PX AIVSTV",99 ,0) .S PXA ERR(11)=$G (PXAA("PAT IENT"))"RT N","PXAIVS TV",100,0)  .S PXAERR (12)="This  value is  not a poin ter to fil e PATIENT/ IHS file #  9000001"" RTN","PXAI VSTV",101, 0) ;"RTN", "PXAIVSTV" ,102,0) ;- --Missing  required i nformation "RTN","PXA IVSTV",103 ,0) I $G(P XAA("OUTSI DE LOCATIO N"))']"",$ G(PXAA("HO S LOC"))'] "",$G(PXAA ("SERVICE  CATEGORY") )'="E" D   Q:$G(STOP) "RTN","PXA IVSTV",104 ,0) .S STO P=1"RTN"," PXAIVSTV", 105,0) .S  PXAERRF=1" RTN","PXAI VSTV",106, 0) .S PXAD I("DIALOG" )=8390001. 001"RTN"," PXAIVSTV", 107,0) .S  PXAERR(9)= "HOS LOC o r OUTSIDE  LOC""RTN", "PXAIVSTV" ,108,0) .S  PXAERR(11 )="BOTH EN TRIES ARE  NULL AND S ERVICE CAT EGORY IS N OT ""E"""" RTN","PXAI VSTV",109, 0) .S PXAE RR(12)="Th e HOSPITAL  LOCATION  (pointer t o the HOSP ITAL LOCAT ION file # 44 ) needs  to be sen t in order  to create  a visit." "RTN","PXA IVSTV",110 ,0) ;"RTN" ,"PXAIVSTV ",111,0) ; ---not a p ointer to  hospital l ocation fi le"RTN","P XAIVSTV",1 12,0) I $D (PXAA("HOS  LOC")) D   Q:$G(STOP )"RTN","PX AIVSTV",11 3,0) .I '$ D(^SC($G(P XAA("HOS L OC")),0))  D  Q:$G(ST OP)"RTN"," PXAIVSTV", 114,0) ..S  STOP=1"RT N","PXAIVS TV",115,0)  ..S PXAER RF=1"RTN", "PXAIVSTV" ,116,0) .. S PXADI("D IALOG")=83 90001.001" RTN","PXAI VSTV",117, 0) ..S PXA ERR(9)="HO S LOC""RTN ","PXAIVST V",118,0)  ..S PXAERR (11)=$G(PX AA("HOS LO C"))"RTN", "PXAIVSTV" ,119,0) .. S PXAERR(1 2)="This H OSPITAL LO CATION is  not a poin ter to the  HOSPITAL  LOCATION f ile #44""R TN","PXAIV STV",120,0 ) ;---hosp ital locat ion is the  dispositi oning loca tion"RTN", "PXAIVSTV" ,121,0) ;A llow a dis positionin g location  to be use d"RTN","PX AIVSTV",12 2,0) ;I $D (PXAA("HOS  LOC")) D   Q:$G(STOP )   ;PX*1. 0*116"RTN" ,"PXAIVSTV ",123,0) ; .I $D(^PX( 815,1,"DHL ","B",$G(P XAA("HOS L OC")))) D   Q:$G(STOP )"RTN","PX AIVSTV",12 4,0) ;..S  STOP=1"RTN ","PXAIVST V",125,0)  ;..S PXAER RF=1"RTN", "PXAIVSTV" ,126,0) ;. .S PXADI(" DIALOG")=8 390001.001 "RTN","PXA IVSTV",127 ,0) ;..S P XAERR(9)=" HOS LOC""R TN","PXAIV STV",128,0 ) ;..S PXA ERR(11)=$G (PXAA("HOS  LOC"))"RT N","PXAIVS TV",129,0)  ;..S PXAE RR(12)="Th is HOSPITA L LOCATION  is a disp ositioning  location  and connot  be used.  Refer to e ntries in  file#815 P CE PARAMET ERS""RTN", "PXAIVSTV" ,130,0) ;- -Not a ser vice categ ory"RTN"," PXAIVSTV", 131,0) I ' $D(PXAA("S ERVICE CAT EGORY")) D   Q:$G(STO P)"RTN","P XAIVSTV",1 32,0) .S S TOP=1"RTN" ,"PXAIVSTV ",133,0) . S PXAERRF= 1"RTN","PX AIVSTV",13 4,0) .S PX ADI("DIALO G")=839000 1.001"RTN" ,"PXAIVSTV ",135,0) . S PXAERR(9 )="SERVICE  CATEGORY" "RTN","PXA IVSTV",136 ,0) .S PXA ERR(11)=$G (PXAA("SER VICE CATEG ORY"))"RTN ","PXAIVST V",137,0)  .S PXAERR( 12)="SERVI CE CATEGOR Y is a req uired fiel d""RTN","P XAIVSTV",1 38,0) Q"RT N","PXAIVS TV",139,0)  ;"RTN","P XAIVSTV",1 40,0)VPTR  ;---Is the  visit sen t TO US va lid?"RTN", "PXAIVSTV" ,141,0) I  $G(PXAVISI T) D  Q:$D (STOP)"RTN ","PXAIVST V",142,0)  .I '$D(^AU PNVSIT(PXA VISIT,0))  D  Q:$G(ST OP)"RTN"," PXAIVSTV", 143,0) ..S  STOP=1"RT N","PXAIVS TV",144,0)  ..S PXAK= 1"RTN","PX AIVSTV",14 5,0) ..S P XAERRF=1"R TN","PXAIV STV",146,0 ) ..S PXAD I("DIALOG" )=8390001. 001"RTN"," PXAIVSTV", 147,0) ..S  PXAERR(7) ="ENCOUNTE R""RTN","P XAIVSTV",1 48,0) ..S  PXAERR(9)= "GENERAL N ATURE""RTN ","PXAIVST V",149,0)  ..S PXAERR (11)=$G(PX AVISIT)"RT N","PXAIVS TV",150,0)  ..S PXAER R(12)="The  value tha t was sent  to us is  not a vali d visit in  the VISIT  file # 90 00010. The  Patients  name will  be derived  from the  visit file  and could  cause the  data to b e given to  the wrong  patient i f not corr ect.""RTN" ,"PXAIVSTV ",151,0) . .S PXAERR( 13)="If th e correct  VISIT isn' t known, s et the 'EN COUNTER' a rray and w e will loo k it up or  create a  correct on e. Setting  both at t he same ti me will on ly add con fusion as  to what da ta is corr ect.""RTN" ,"PXAIVSTV ",152,0) Q :$G(PXAVIS IT)"RTN"," PXAIVSTV", 153,0) Q"R TN","PXBAP I1")0^30^B 59480552"R TN","PXBAP I1",1,0)PX BAPI1 ;ISL /JVS,dee -  PCE's API  - intervi ew questio ns ;5/6/05  2:59pm"RT N","PXBAPI 1",2,0) ;; 1.0;PCE PA TIENT CARE  ENCOUNTER ;**1,9,23, 56,104,111 ,113,122,1 16,130,147 ,151,124,1 64,182,168 ,207**;Aug  12, 1996; Build 54"R TN","PXBAP I1",3,0) ; ;"RTN","PX BAPI1",4,0 ) Q"RTN"," PXBAPI1",5 ,0) ;"RTN" ,"PXBAPI1" ,6,0)PROCE SS(PXBEXIT ) ;"RTN"," PXBAPI1",7 ,0) N PXBR EQ"RTN","P XBAPI1",8, 0) I WHAT= "INTV" D"R TN","PXBAP I1",9,0) .  ;-- Inter view is al l of the q uestions"R TN","PXBAP I1",10,0)  . D ADQ(.P XBEXIT) I  PXBEXIT<1  Q "RTN","P XBAPI1",11 ,0)1 . D P RV(.PXBEXI T) I PXBEX IT<1 Q"RTN ","PXBAPI1 ",12,0)3 .  D POV(.PX BEXIT) I P XBEXIT<1 Q "RTN","PXB API1",13,0 )2 . D CPT (.PXBEXIT)  I PXBEXIT <1 Q"RTN", "PXBAPI1", 14,0) . I  $P($G(^AUP NVSIT($G(P XBVST),150 )),"^",3)= "O" S PXBE XIT=0 Q"RT N","PXBAPI 1",15,0) .  I '$$DISP OSIT^PXUTL 1($G(PXBPA T),$P($G(^ AUPNVSIT(P XBVST,0)), "^",1),$G( PXBVST)) D  STP(.PXBE XIT) I PXB EXIT<1 Q"R TN","PXBAP I1",16,0)  E  I WHAT= "ADDEDIT"  D"RTN","PX BAPI1",17, 0) . D ADD EDIT"RTN", "PXBAPI1", 18,0) E  I  WHAT="ADQ " D"RTN"," PXBAPI1",1 9,0) . ;--  Adminstra tive quest ions"RTN", "PXBAPI1", 20,0) . D  ADQ(.PXBEX IT)"RTN"," PXBAPI1",2 1,0) E  I  WHAT="CODT " D"RTN"," PXBAPI1",2 2,0) . ;--  Check out  Date/Time "RTN","PXB API1",23,0 ) . D CODT (.PXBEXIT) "RTN","PXB API1",24,0 ) . Q:PXBE XIT<1"RTN" ,"PXBAPI1" ,25,0) . D  VISIT(.PX BEXIT)"RTN ","PXBAPI1 ",26,0) .  I PXBVST'> 0 S PXBEXI T=-2 Q"RTN ","PXBAPI1 ",27,0) E   I WHAT="S CC" D"RTN" ,"PXBAPI1" ,28,0) . ; -- Service  connected  condition s"RTN","PX BAPI1",29, 0) . S PXC ECAT="VST"  D SCC(.PX BEXIT) K P XCECAT"RTN ","PXBAPI1 ",30,0) .  Q:PXBEXIT< 1"RTN","PX BAPI1",31, 0) . D VIS IT(.PXBEXI T)"RTN","P XBAPI1",32 ,0) . I PX BVST'>0 S  PXBEXIT=-2  Q"RTN","P XBAPI1",33 ,0) E  I W HAT="PRV"  D"RTN","PX BAPI1",34, 0) . ;-- P roviders"R TN","PXBAP I1",35,0)  . D PRV(.P XBEXIT)"RT N","PXBAPI 1",36,0) E   I WHAT=" CPT" D"RTN ","PXBAPI1 ",37,0) .  ;-- Provid ers and CP T codes"RT N","PXBAPI 1",38,0) .  D CPT(.PX BEXIT)"RTN ","PXBAPI1 ",39,0) E   I WHAT="P OV" D"RTN" ,"PXBAPI1" ,40,0) . ; -- Diagnos es"RTN","P XBAPI1",41 ,0) . D PO V(.PXBEXIT )"RTN","PX BAPI1",42, 0) E  I WH AT="STP" D "RTN","PXB API1",43,0 ) . ;-- St op Codes"R TN","PXBAP I1",44,0)  . D STP(.P XBEXIT)"RT N","PXBAPI 1",45,0) E   S PXBEXI T=-3 W !," Procedure  ""INTV^PXA PI"" was c alled inco rrectly, c ontact IRM .""RTN","P XBAPI1",46 ,0) Q"RTN" ,"PXBAPI1" ,47,0) ;"R TN","PXBAP I1",48,0)A DDEDIT ;"R TN","PXBAP I1",49,0)  N PXANS"RT N","PXBAPI 1",50,0)AD DEDIT1 ;"R TN","PXBAP I1",51,0)  D ADQ(.PXB EXIT)"RTN" ,"PXBAPI1" ,52,0) G:P XBEXIT<1 A DDEDIT2"RT N","PXBAPI 1",53,0) D  PRV(.PXBE XIT)"RTN", "PXBAPI1", 54,0) G:PX BEXIT<1 AD DEDIT2"RTN ","PXBAPI1 ",55,0) D  POV(.PXBEX IT)"RTN"," PXBAPI1",5 6,0) G:PXB EXIT<1 ADD EDIT2"RTN" ,"PXBAPI1" ,57,0) ;"R TN","PXBAP I1",58,0)  ;Call to C PT is not  determined  by a cred it stop co de any mor e"RTN","PX BAPI1",59, 0) ;"RTN", "PXBAPI1", 60,0) D CP T(.PXBEXIT )"RTN","PX BAPI1",61, 0) G:PXBEX IT<1 ADDED IT2"RTN"," PXBAPI1",6 2,0) I PXB VST>0,'$D( ^AUPNVCPT( "AD",PXBVS T)) D ADDE DIT3   ;PX *1.0*182"R TN","PXBAP I1",63,0)  Q   ; PX*1 .0*182 add ed quit, o therwise u ser is for ced to del ete enc."R TN","PXBAP I1",64,0)  ;"RTN","PX BAPI1",65, 0)ADDEDIT2  ;"RTN","P XBAPI1",66 ,0) I PXBV ST>0,'$D(^ AUPNVCPT(" AD",PXBVST )),'$D(^AU PNVSIT("AD ",PXBVST))  D  I PXAN S'=1 S PXB EXIT=1 G A DDEDIT1"RT N","PXBAPI 1",67,0) .  N DIR,X,Y "RTN","PXB API1",68,0 ) . W !!"R TN","PXBAP I1",69,0)  . S DIR(0) ="Y""RTN", "PXBAPI1", 70,0) . S  DIR("A",1) ="Must hav e a STOP C ODE or a P ROCEDURE t o complete  this acti on.""RTN", "PXBAPI1", 71,0) . S  DIR("A")=" Do you wan t to delet e this enc ounter""RT N","PXBAPI 1",72,0) .  S DIR("B" )="NO""RTN ","PXBAPI1 ",73,0) .  D ^DIR"RTN ","PXBAPI1 ",74,0) .  S PXANS=Y" RTN","PXBA PI1",75,0)  . Q:PXANS '=1"RTN"," PXBAPI1",7 6,0) . I $ $DELVFILE^ PXAPIDEL(" ALL",PXBVS T,"","","" ,"","")=1  S PXBEXIT= -1"RTN","P XBAPI1",77 ,0) I PXBV ST>0,'$D(^ AUPNVSIT(P XBVST,0))  S PXBVST=" ""RTN","PX BAPI1",78, 0) Q"RTN", "PXBAPI1", 79,0) ;"RT N","PXBAPI 1",80,0)AD DEDIT3 ;ad ded PX*1.0 *182"RTN", "PXBAPI1", 81,0) N DI R,X,Y"RTN" ,"PXBAPI1" ,82,0) W ! !"RTN","PX BAPI1",83, 0) S DIR(0 )="Y""RTN" ,"PXBAPI1" ,84,0) S D IR("A",1)= "Must have  a STOP CO DE or a PR OCEDURE to  complete  this actio n.""RTN"," PXBAPI1",8 5,0) S DIR ("A")="Do  you want t o delete t his encoun ter""RTN", "PXBAPI1", 86,0) S DI R("B")="NO ""RTN","PX BAPI1",87, 0) D ^DIR" RTN","PXBA PI1",88,0)  Q:Y'=1"RT N","PXBAPI 1",89,0) I  $$DELVFIL E^PXAPIDEL ("ALL",PXB VST,"","", "","","")= 1 S PXBVST ="""RTN"," PXBAPI1",9 0,0) Q"RTN ","PXBAPI1 ",91,0) ;" RTN","PXBA PI1",92,0) ADQ(PXBEXI T) ;Ask th e Administ ration que stions"RTN ","PXBAPI1 ",93,0) I  PXBVST'>0  D"RTN","PX BAPI1",94, 0) . ;This  is only d one for ne w visits"R TN","PXBAP I1",95,0)  . I PXBPAT '>0 S PXBP AT=$$ASKPA T I PXBPAT '>0 S PXBE XIT=-1 Q"R TN","PXBAP I1",96,0)  . S DFN=PX BPAT"RTN", "PXBAPI1", 97,0) . I  PXBHLOC'>0  S PXBHLOC =$$ASKHL I  PXBHLOC'> 0 S PXBEXI T=-1 Q"RTN ","PXBAPI1 ",98,0) .  S PXBVSTDT =$S(PXBAPP T>0:PXBAPP T,1:$$ASKD T) I PXBVS TDT'>0 S P XBEXIT=-1  Q"RTN","PX BAPI1",99, 0) . I PXB APPT'>0&PX BHLOC'=+$G (^DPT(PXBP AT,"S",PXB VSTDT,0))  D"RTN","PX BAPI1",100 ,0) .. ;Th is is only  done if t here is no  appointme nt."RTN"," PXBAPI1",1 01,0) .. S  PXELAP=$$ ELAP^SDPCE (PXBPAT,PX BHLOC)"RTN ","PXBAPI1 ",102,0) I  PXBEXIT'< 1,PXBHLOC' >0 S PXBHL OC=$$ASKHL  I PXBHLOC '>0 S PXBE XIT=-1 Q"R TN","PXBAP I1",103,0)  I PXBEXIT '<1 D CODT (.PXBEXIT) "RTN","PXB API1",104, 0) I PXBEX IT'<1,WHAT '="INTV" S  PXCECAT=" VST" D SCC (.PXBEXIT)  K PXCECAT "RTN","PXB API1",105, 0) I PXBEX IT'<1 D"RT N","PXBAPI 1",106,0)  . D VISIT( .PXBEXIT)" RTN","PXBA PI1",107,0 ) . I PXBV ST'>0 S PX BEXIT=-2 Q "RTN","PXB API1",108, 0) Q"RTN", "PXBAPI1", 109,0) ;"R TN","PXBAP I1",110,0) ASKPAT() ; Ask user f or a patie nt"RTN","P XBAPI1",11 1,0) ;DIC  on file 90 00001"RTN" ,"PXBAPI1" ,112,0) N  DIR,DIC,Y, X,DA"RTN", "PXBAPI1", 113,0) S D IR(0)="P^9 000001:AEM Q""RTN","P XBAPI1",11 4,0) S DIR ("A")="Pat ient Name" "RTN","PXB API1",115, 0) D ^DIR" RTN","PXBA PI1",116,0 ) Q $S(+Y> 0:+Y,1:-1) "RTN","PXB API1",117, 0) ;"RTN", "PXBAPI1", 118,0)ASKH L() ;Ask u ser for a  Hospital L ocation"RT N","PXBAPI 1",119,0)A SKHL2 ;DIC  on file 4 4"RTN","PX BAPI1",120 ,0) N DIR, DIC,Y,X,DA ,PXRES"RTN ","PXBAPI1 ",121,0) S  DIR(0)="P A^44:AEMQ" "RTN","PXB API1",122, 0) S DIR(" A")="Clini c: ""RTN", "PXBAPI1", 123,0) ; n ot occasio n of servi ce and not  dispositi oning"RTN" ,"PXBAPI1" ,124,0) ;I  PXALHLOC  S DIR("S") ="I '+$G(^ (""OOS"")) &'$O(^PX(8 15,1,""DHL "",""B"",Y ,0))""RTN" ,"PXBAPI1" ,125,0) ;  not occasi on of serv ice only    ;PX*1.0*1 16"RTN","P XBAPI1",12 6,0) I PXA LHLOC S DI R("S")="I  '+$G(^(""O OS""))"    ;PX*1.0*11 6"RTN","PX BAPI1",127 ,0) ; only  clinic th at are not  occasion  of service  and not d isposition ing"RTN"," PXBAPI1",1 28,0) ;E   S DIR("S") ="I $P(^(0 ),U,3)=""C ""&'+$G(^( ""OOS""))& '$O(^PX(81 5,1,""DHL" ",""B"",Y, 0))""RTN", "PXBAPI1", 129,0) E   S DIR("S") ="I $P(^(0 ),U,3)=""C ""&'+$G(^( ""OOS""))"    ;PX*1.0 *116"RTN", "PXBAPI1", 130,0) D ^ DIR"RTN"," PXBAPI1",1 31,0) ;ena ble to sel ect a disp osition cl inic   ;PX *1.0*116"R TN","PXBAP I1",132,0)  ;I $D(^PX (815,1,"DH L","B",+Y) ) D HELPDI SP^PXCEVSI T W !,$C(7 ) G ASKHL2 "RTN","PXB API1",133, 0) ; disal low select ion of cli nics with  non confor ming stop  codes"RTN" ,"PXBAPI1" ,134,0) I  +Y>0 S PXR ES=$$CLNCK ^SDUTL2(+Y ,1) I 'PXR ES D  G AS KHL2"RTN", "PXBAPI1", 135,0) .W  !,?5,"Clin ic MUST be  corrected  before co ntinuing." "RTN","PXB API1",136, 0) Q $S(+Y >0:+Y,1:-1 )"RTN","PX BAPI1",137 ,0) ;"RTN" ,"PXBAPI1" ,138,0)ASK DT() ;Ask  user for t he encount er Date/Ti me"RTN","P XBAPI1",13 9,0) N DIR ,Y,X,DA"RT N","PXBAPI 1",140,0)  S DIR(0)=" D^"_$S(PXL IMDT>29600 00:PXLIMDT ,1:"")_":" _(DT+.24)_ ":AEPRSX"" RTN","PXBA PI1",141,0 ) S DIR("A ")="Encoun ter Date a nd Time""R TN","PXBAP I1",142,0)  S DIR("?" )="Enter t he Date an d Time of  this encou nter""RTN" ,"PXBAPI1" ,143,0) D  ^DIR"RTN", "PXBAPI1", 144,0) Q $ S(+Y>0:+Y, 1:-1)"RTN" ,"PXBAPI1" ,145,0) ;" RTN","PXBA PI1",146,0 )CODT(PXBE XIT) ;Ask  the user t he Check o ut Date/Ti me"RTN","P XBAPI1",14 7,0) N PXC HKOUT"RTN" ,"PXBAPI1" ,148,0) D  CHIKOUT^PX BAPI2("",P XBPAT,PXBH LOC,PXBVST DT)"RTN"," PXBAPI1",1 49,0) S PX BCODT=PXCH KOUT"RTN", "PXBAPI1", 150,0) S:P XCHKOUT=-1  PXBCODT=" ""RTN","PX BAPI1",151 ,0) ;; PX* 1*113 - Ch ange for E AS*1*3 App ointment p rocessing  removed"RT N","PXBAPI 1",152,0)  ;S X="EASM TCHK" X ^% ZOSF("TEST ") I $T D   Q:PXBEXIT <1"RTN","P XBAPI1",15 3,0) ;. S: $G(EASACT) '="W" EASA CT="C""RTN ","PXBAPI1 ",154,0) ; . I $$MT^E ASMTCHK(PX BPAT,"",EA SACT,PXBVS TDT) D  S  PXBEXIT=-1 "RTN","PXB API1",155, 0) ;. . D  PAUSE^VALM 1"RTN","PX BAPI1",156 ,0) I WHAT '["ADDEDIT ",PXCHKOUT =-1 S PXBE XIT=-1"RTN ","PXBAPI1 ",157,0) I  $G(PXBVST ),$$DISPOS IT^PXUTL1( DFN,$P($G( ^AUPNVSIT( PXBVST,0)) ,"^",1),PX BVST) S PX BEXIT=1"RT N","PXBAPI 1",158,0)  Q"RTN","PX BAPI1",159 ,0) ;"RTN" ,"PXBAPI1" ,160,0)SCC (PXBEXIT)  ;Ask the u ser the Se rvice conn ected cond itions"RTN ","PXBAPI1 ",161,0) N  PXBDATA,P XBCLASS,PX BOUTEN,PXD OD"RTN","P XBAPI1",16 2,0) S (PX BOUTEN,PXD OD)="""RTN ","PXBAPI1 ",163,0) ; I $$APPOIN T^PXUTL1(P XBPAT,PXBV STDT,PXBHL OC) D"RTN" ,"PXBAPI1" ,164,0) ;.  S PXBOUTE N=$P($G(^D PT(+PXBPAT ,"S",+PXBV STDT,0))," ^",20)"RTN ","PXBAPI1 ",165,0) ; E  I $$DIS POSIT^PXUT L1(PXBPAT, PXBVSTDT,P XBVST) D"R TN","PXBAP I1",166,0)  ;. S PXBO UTEN=+$P($ G(^DPT(+PX BPAT,"DIS" ,9999999-P XBVSTDT,0) ),"^",18)" RTN","PXBA PI1",167,0 ) ;I 'PXBO UTEN,$G(PX BVST)>0 S  PXBOUTEN=$ O(^SCE("AV SIT",PXBVS T,0))"RTN" ,"PXBAPI1" ,168,0) ;D  CLASS^PXB API21(PXBO UTEN,PXBPA T,PXBVSTDT ,PXBHLOC)" RTN","PXBA PI1",169,0 ) D CLASS^ PXBAPI21(P XBOUTEN,PX BPAT,PXBVS TDT,PXBHLO C,PXBVST)" RTN","PXBA PI1",170,0 ) ;PX*1*11 1 - Add HN C"RTN","PX BAPI1",171 ,0) ;  djs   PX*1.0*2 07  RSD SP EC # 2.6.2 .4.4.1   C hanged for  Camp Leje une enhanc ement"RTN" ,"PXBAPI1" ,172,0) F  PXBCLASS=1 :1:9 I $G( PXBDATA("E RR",PXBCLA SS))=4 S P XBEXIT=-1  Q  ; chang ed 6/17/98  for MST e nhancement "RTN","PXB API1",173, 0) Q:PXBEX IT<1"RTN", "PXBAPI1", 174,0) I $ G(PXDOD) S  PXBEXIT=- 1 Q"RTN"," PXBAPI1",1 75,0) S PX B800(1)=$P ($G(PXBDAT A(3)),"^", 2)"RTN","P XBAPI1",17 6,0) S PXB 800(2)=$P( $G(PXBDATA (1)),"^",2 )"RTN","PX BAPI1",177 ,0) S PXB8 00(3)=$P($ G(PXBDATA( 2)),"^",2) "RTN","PXB API1",178, 0) S PXB80 0(4)=$P($G (PXBDATA(4 )),"^",2)" RTN","PXBA PI1",179,0 ) S PXB800 (5)=$P($G( PXBDATA(5) ),"^",2) ; added 6/17 /98 for MS T enhancem ent"RTN"," PXBAPI1",1 80,0) ;PX* 1*111 - Ad d HNC"RTN" ,"PXBAPI1" ,181,0) S  PXB800(6)= $P($G(PXBD ATA(6)),"^ ",2)"RTN", "PXBAPI1", 182,0) S P XB800(7)=$ P($G(PXBDA TA(7)),"^" ,2)"RTN"," PXBAPI1",1 83,0) S PX B800(8)=$P ($G(PXBDAT A(8)),"^", 2)"RTN","P XBAPI1",18 4,0) ;  dj s  PX*1.0* 207  RSD S PEC # 2.6. 2.4.4.1    Added item  to array  for Camp L ejeune"RTN ","PXBAPI1 ",185,0) S  PXB800(9) =$P($G(PXB DATA(9))," ^",2)"RTN" ,"PXBAPI1" ,186,0) Q" RTN","PXBA PI1",187,0 ) ;"RTN"," PXBAPI1",1 88,0)VISIT (PXBEXIT)  ;Creat or  edit the V isit"RTN", "PXBAPI1", 189,0) ;Se t up ^TMP( "PXK",$J a nd call PX K"RTN","PX BAPI1",190 ,0) I PXBV ST>0 L +^A UPNVSIT(PX BVST):10 E   W !!,$C( 7),"Cannot  edit at t his time,  try again  later." D  WAIT^PXCEH ELP S PXBE XIT=-2 Q"R TN","PXBAP I1",191,0)  K ^TMP("P XK",$J)"RT N","PXBAPI 1",192,0)  N PXBNODE, PXBAFTER,P XKERROR"RT N","PXBAPI 1",193,0)  F PXBNODE= 0,21,150,8 00,811,812  D"RTN","P XBAPI1",19 4,0) . S P XBAFTER(PX BNODE)=$S( PXBVST>0:$ G(^AUPNVSI T(PXBVST,P XBNODE)),1 :"")"RTN", "PXBAPI1", 195,0) . S  ^TMP("PXK ",$J,"VST" ,1,PXBNODE ,"BEFORE") =PXBAFTER( PXBNODE)"R TN","PXBAP I1",196,0)  I PXBVST' >0 D"RTN", "PXBAPI1", 197,0) . S  $P(PXBAFT ER(0),"^", 1)=PXBVSTD T"RTN","PX BAPI1",198 ,0) . S $P (PXBAFTER( 0),"^",5)= PXBPAT"RTN ","PXBAPI1 ",199,0) .  S $P(PXBA FTER(0),"^ ",8)=$P(^S C(PXBHLOC, 0),"^",7)" RTN","PXBA PI1",200,0 ) . S:PXBA PPT>0 $P(P XBAFTER(0) ,"^",7)="A " ;PX*1*12 4"RTN","PX BAPI1",201 ,0) . S $P (PXBAFTER( 150),"^",3 )="P""RTN" ,"PXBAPI1" ,202,0) .  S $P(PXBAF TER(812)," ^",2)=PXBP KG"RTN","P XBAPI1",20 3,0) . S $ P(PXBAFTER (812),"^", 3)=PXBSOUR C"RTN","PX BAPI1",204 ,0) S $P(P XBAFTER(0) ,"^",18)=$ G(PXBCODT) "RTN","PXB API1",205, 0) S:$P(PX BAFTER(0), "^",22)=""  $P(PXBAFT ER(0),"^", 22)=PXBHLO C"RTN","PX BAPI1",206 ,0) S $P(P XBAFTER(80 0),"^",1)= $G(PXB800( 1))"RTN"," PXBAPI1",2 07,0) S $P (PXBAFTER( 800),"^",2 )=$G(PXB80 0(2))"RTN" ,"PXBAPI1" ,208,0) S  $P(PXBAFTE R(800),"^" ,3)=$G(PXB 800(3))"RT N","PXBAPI 1",209,0)  S $P(PXBAF TER(800)," ^",4)=$G(P XB800(4))" RTN","PXBA PI1",210,0 ) S $P(PXB AFTER(800) ,"^",5)=$G (PXB800(5) ) ;added 6 /17/98 for  MST emhan cement"RTN ","PXBAPI1 ",211,0) ; PX*1*111 -  Add HNC"R TN","PXBAP I1",212,0)  S $P(PXBA FTER(800), "^",6)=$G( PXB800(6)) "RTN","PXB API1",213, 0) S $P(PX BAFTER(800 ),"^",7)=$ G(PXB800(7 ))"RTN","P XBAPI1",21 4,0) S $P( PXBAFTER(8 00),"^",8) =$G(PXB800 (8))"RTN", "PXBAPI1", 215,0) ;   djs  PX*1. 0*207  RSD  SPEC # 2. 6.2.4.4.1    Set PXBA FTER(800)  array piec e #9 to va lue of CL- V Ind."RTN ","PXBAPI1 ",216,0) S  $P(PXBAFT ER(800),"^ ",9)=$G(PX B800(9))"R TN","PXBAP I1",217,0)  I $D(PXEL AP)#2 D"RT N","PXBAPI 1",218,0)  . S $P(PXB AFTER(0)," ^",21)=+PX ELAP"RTN", "PXBAPI1", 219,0) F P XBNODE=0,2 1,150,800, 811,812 D" RTN","PXBA PI1",220,0 ) . S ^TMP ("PXK",$J, "VST",1,PX BNODE,"AFT ER")=PXBAF TER(PXBNOD E)"RTN","P XBAPI1",22 1,0) S ^TM P("PXK",$J ,"VST",1," IEN")=$S(P XBVST>0:PX BVST,1:"") "RTN","PXB API1",222, 0) S ^TMP( "PXK",$J," SOR")=PXBS OURC"RTN", "PXBAPI1", 223,0) D E N1^PXKMAIN "RTN","PXB API1",224, 0) I PXBVS T>0 L -^AU PNVSIT(PXB VST):5"RTN ","PXBAPI1 ",225,0) S  PXBVST=$G (^TMP("PXK ",$J,"VST" ,1,"IEN")) "RTN","PXB API1",226, 0) Q"RTN", "PXBAPI1", 227,0) ;"R TN","PXBAP I1",228,0) CPT(PXBEXI T) ;Ask th e user Pro viders and  CTPs"RTN" ,"PXBAPI1" ,229,0) D  CPT^PXBMCP T(PXBVST)  K PRVDR"RT N","PXBAPI 1",230,0)  Q"RTN","PX BAPI1",231 ,0) ;"RTN" ,"PXBAPI1" ,232,0)POV (PXBEXIT)  ;Ask the u ser Diagno ses"RTN"," PXBAPI1",2 33,0) D PO V^PXBMPOV( PXBVST) K  PRVDR"RTN" ,"PXBAPI1" ,234,0) Q" RTN","PXBA PI1",235,0 ) ;"RTN"," PXBAPI1",2 36,0)PRV(P XBEXIT) ;A sk the use r Provider s"RTN","PX BAPI1",237 ,0) D PRV^ PXBMPRV(PX BVST,"PRV" ) K PRVDR" RTN","PXBA PI1",238,0 ) Q"RTN"," PXBAPI1",2 39,0) ;"RT N","PXBAPI 1",240,0)S TP(PXBEXIT ) ;Ask the  user Stop  Codes"RTN ","PXBAPI1 ",241,0) I  $L($T(DAT E^SCDXUTL) ),$$DATE^S CDXUTL(+$G (^AUPNVSIT (PXBVST,0) )) Q"RTN", "PXBAPI1", 242,0) D S TP^PXBMSTP (PXBVST) K  PRVDR"RTN ","PXBAPI1 ",243,0) Q "RTN","PXB API1",244, 0) ;"RTN", "PXBAPI21" )0^6^B3330 8732"RTN", "PXBAPI21" ,1,0)PXBAP I21 ;ISL/D CM - API f or Classif ication ch eck out ;4 /13/05 12: 55pm"RTN", "PXBAPI21" ,2,0) ;;1. 0;PCE PATI ENT CARE E NCOUNTER;* *130,147,1 24,184,168 ,207**;Aug  12, 1996; Build 54"R TN","PXBAP I21",3,0)C LASS(ENCOW NTR,DFN,AP TDT,LOC,VI SIT) ;Edit  classific ation fiel ds"RTN","P XBAPI21",4 ,0) ; Inpu t  - ENCOW NTR - ien  of ^SCE(ie n (409.68  Outpatient  Encounter  file)"RTN ","PXBAPI2 1",5,0) ;           E NCOWNTR op tional if  DFN,LOC,AP TDT params  used"RTN" ,"PXBAPI21 ",6,0) ;           DF N - ien of  ^DPT(DFN,  (only use d if no EN COWNTR)"RT N","PXBAPI 21",7,0) ;            LOC - ien  of ^SC(LOC ,  (only u sed if no  ENCOWNTR)" RTN","PXBA PI21",8,0)  ;           APTDT -  Appointmen t Date/tim e (only us ed if no E NCOWNTR)"R TN","PXBAP I21",9,0)  ;           VISIT - o ptional if  no ENCOWN TR look fo r main enc ounter tha t"RTN","PX BAPI21",10 ,0) ;                    points  to this vi sit"RTN"," PXBAPI21", 11,0) ; Ou tput - PXB DATA(Class ification  type)=OutP T Class ie n^Value"RT N","PXBAPI 21",12,0)  ;           PXBDATA(" ERR",Class  type)=1 B ad ptr to  409.41"RTN ","PXBAPI2 1",13,0) ;                                        =2 D ATA entry  not applic able"RTN", "PXBAPI21" ,14,0) ;                                        =3 DAT A entry un editable"R TN","PXBAP I21",15,0)  ;                                       =4  User ^ ou t of promp t"RTN","PX BAPI21",16 ,0) ;             Cla ssificatio n type 1 -  Agent Ora nge"RTN"," PXBAPI21", 17,0) ;                                   2  - Ionizin g Radiatio n"RTN","PX BAPI21",18 ,0) ;                                   3 -  Service C onnected"R TN","PXBAP I21",19,0)  ;                                   4 - SW  Asia Codi tions"RTN" ,"PXBAPI21 ",20,0) ;                                    5 - Milit ary Sexual  Trauma"RT N","PXBAPI 21",21,0)  ;                                   6 - Hea d and/or N eck Cancer "RTN","PXB API21",22, 0) ;                                   7 -  Combat Vet eran"RTN", "PXBAPI21" ,23,0) ;                                    8 - Projec t 112/SHAD "RTN","PXB API21",24, 0) ;                                   9 -  Camp Lejue ne"RTN","P XBAPI21",2 5,0) ;"RTN ","PXBAPI2 1",26,0) ;  Ext Refer ences: ^SC E(DA,0)                INP^SDAM2 "RTN","PXB API21",27, 0) ;                   REQ^SDM1A                 CLINI C^SDAMU"RT N","PXBAPI 21",28,0)  ;                  EX OE^SDCOU2               CLOE^SDC O21"RTN"," PXBAPI21", 29,0) ;                   SEQ^SD CO21               CL ^SDCO21"RT N","PXBAPI 21",30,0)  ;   In ^PX BAPI22"RTN ","PXBAPI2 1",31,0) ;                   ^DG (43,1,"SCL R")  piece  24"RTN"," PXBAPI21", 32,0) ;                   ^SD(40 9.41,DA,0)         ^S D(409.41,D A,2)"RTN", "PXBAPI21" ,33,0) ;                   VAL^S DCODD               S C^SDCO23"R TN","PXBAP I21",34,0)  I $G(ENCO WNTR)'>0,$ G(VISIT)>0  D SC^PXCE VFI2($P(^A UPNVSIT(VI SIT,0),U,5 )) D"RTN", "PXBAPI21" ,35,0) . S  ENCOWNTR= $O(^SCE("A VSIT",VISI T,0))"RTN" ,"PXBAPI21 ",36,0) .  I ENCOWNTR ,$P(^SCE(E NCOWNTR,0) ,"^",6) S  ENCOWNTR=$ P(^SCE(ENC OWNTR,0)," ^",6)"RTN" ,"PXBAPI21 ",37,0) N  IEN,IFN,SD CLOEY,ORG, END,DA,X,S QUIT"RTN", "PXBAPI21" ,38,0) I $ G(ENCOWNTR ) Q:'$D(^S CE(+ENCOWN TR,0))  N  APTDT,DFN, LOC S END= 0,X0=^(0)  D ENCHK(EN COWNTR,X0)  Q:END  G  ON"RTN","P XBAPI21",3 9,0) Q:'$G (DFN)!'$G( LOC)!'$G(A PTDT)"RTN" ,"PXBAPI21 ",40,0) D  SC^PXCEVFI 2(DFN)"RTN ","PXBAPI2 1",41,0) S  X=$G(^DPT (DFN,"S",A PTDT,0))"R TN","PXBAP I21",42,0)  I +X,+X=L OC,$P(X,"^ ",20),$D(^ SCE($P(X," ^",20),0))  S ENCOWNT R=$P(X,"^" ,20),END=0 ,X0=^(0) D  ENCHK(ENC OWNTR,X0)  Q:END  G O N"RTN","PX BAPI21",43 ,0)ON D AS KCL($G(ENC OWNTR),.SD CLOEY,DFN, APTDT)"RTN ","PXBAPI2 1",44,0) S  END=0 D O PCHK(DFN,L OC,APTDT)  I END Q"RT N","PXBAPI 21",45,0)  I '$D(SDCL OEY) Q"RTN ","PXBAPI2 1",46,0) I  $G(PXCECA T)="POV" D "RTN","PXB API21",47, 0) .I $P($ G(PXCEAFTR (800)),"^" ,1)]"",$D( SDCLOEY(3) ) S $P(SDC LOEY(3),"^ ",2)=$P(PX CEAFTR(800 ),"^",1)"R TN","PXBAP I21",48,0)  .I $P($G( PXCEAFTR(8 00)),"^",2 )]"",$D(SD CLOEY(1))  S $P(SDCLO EY(1),"^", 2)=$P(PXCE AFTR(800), "^",2)"RTN ","PXBAPI2 1",49,0) . I $P($G(PX CEAFTR(800 )),"^",3)] "",$D(SDCL OEY(2)) S  $P(SDCLOEY (2),"^",2) =$P(PXCEAF TR(800),"^ ",3)"RTN", "PXBAPI21" ,50,0) .I  $P($G(PXCE AFTR(800)) ,"^",4)]"" ,$D(SDCLOE Y(4)) S $P (SDCLOEY(4 ),"^",2)=$ P(PXCEAFTR (800),"^", 4)"RTN","P XBAPI21",5 1,0) .I $P ($G(PXCEAF TR(800))," ^",5)]"",$ D(SDCLOEY( 5)) S $P(S DCLOEY(5), "^",2)=$P( PXCEAFTR(8 00),"^",5) "RTN","PXB API21",52, 0) .I $P($ G(PXCEAFTR (800)),"^" ,6)]"",$D( SDCLOEY(6) ) S $P(SDC LOEY(6),"^ ",2)=$P(PX CEAFTR(800 ),"^",6)"R TN","PXBAP I21",53,0)  .I $P($G( PXCEAFTR(8 00)),"^",7 )]"",$D(SD CLOEY(7))  S $P(SDCLO EY(7),"^", 2)=$P(PXCE AFTR(800), "^",7)"RTN ","PXBAPI2 1",54,0) . I $P($G(PX CEAFTR(800 )),"^",8)] "",$D(SDCL OEY(8)) S  $P(SDCLOEY (8),"^",2) =$P(PXCEAF TR(800),"^ ",8)"RTN", "PXBAPI21" ,55,0) .;   djs   PX* 1.0*207  R SD SPEC #2 .6.2.4.2.1  & 2.6.2.4 .3.1  Add  item to ar ray for Ca mp Lejuene "RTN","PXB API21",56, 0) .I $P($ G(PXCEAFTR (800)),"^" ,9)]"",$D( SDCLOEY(9) ) S $P(SDC LOEY(9),"^ ",2)=$P(PX CEAFTR(800 ),"^",9)"R TN","PXBAP I21",57,0)  I $D(SDCL OEY) D ASK ($G(ENCOWN TR),.SDCLO EY,.SQUIT)  Q:$D(SQUI T)"RTN","P XBAPI21",5 8,0) Q"RTN ","PXBAPI2 1",59,0)AS KCL(ENCOWN TR,SDCLOEY ,DFN,APTDT ) ;Ask cla ssificatio ns on chec k out"RTN" ,"PXBAPI21 ",60,0) I  $G(ENCOWNT R) D CLOE^ SDCO21(ENC OWNTR,.SDC LOEY) Q"RT N","PXBAPI 21",61,0)  D CL^SDCO2 1(DFN,APTD T,"",.SDCL OEY)"RTN", "PXBAPI21" ,62,0) Q"R TN","PXBAP I21",63,0) ASK(ENCOWN TR,SDCLOEY ,SQUIT) ;A sk classif ications"R TN","PXBAP I21",64,0)  N I,IOINH I,IOINORM, TYPI,TYPSE Q,CTS,X,PX VST"RTN"," PXBAPI21", 65,0) S X= "IOINHI;IO INORM" D E NDR^%ZISS" RTN","PXBA PI21",66,0 ) I '$D(SD CLOEY) Q"R TN","PXBAP I21",67,0)  W !!,"---  ",IOINHI, "Classific ation",IOI NORM," ---  [",IOINHI ,"Required ",IOINORM, "]""RTN"," PXBAPI21", 68,0) W !  S TYPSEQ=$ $SEQ^SDCO2 1 ;Get cla ssificatio n type seq uence (3,1 ,2,4,5,6,7 ,8,9)"RTN" ,"PXBAPI21 ",69,0) F  CTS=1:1 S  TYPI=+$P(T YPSEQ,",", CTS) Q:'TY PI!($D(SQU IT))  D"RT N","PXBAPI 21",70,0)  .I $D(SDCL OEY(TYPI))  D"RTN","P XBAPI21",7 1,0) ..S P XVST=$P($G (X0),U,5)  I 'PXVST,( $G(PXCECAT )="VST")!( $G(PXCECAT )="SIT") Q "RTN","PXB API21",72, 0) ..I $G( PXCECAT)=" VST",TYPI= 3,($P($G(^ AUPNVSIT(P XVST,800)) ,U,11)="1" )  Q"RTN", "PXBAPI21" ,73,0) ..I  $G(PXCECA T)="VST",T YPI=1,($P( $G(^AUPNVS IT(PXVST,8 00)),U,12) ="1")  Q"R TN","PXBAP I21",74,0)  ..I $G(PX CECAT)="VS T",TYPI=2, ($P($G(^AU PNVSIT(PXV ST,800)),U ,13)="1")   Q"RTN","P XBAPI21",7 5,0) ..I $ G(PXCECAT) ="VST",TYP I=4,($P($G (^AUPNVSIT (PXVST,800 )),U,14)=" 1")  Q"RTN ","PXBAPI2 1",76,0) . .I $G(PXCE CAT)="VST" ,TYPI=5,($ P($G(^AUPN VSIT(PXVST ,800)),U,1 5)="1")  Q "RTN","PXB API21",77, 0) ..I $G( PXCECAT)=" VST",TYPI= 6,($P($G(^ AUPNVSIT(P XVST,800)) ,U,16)="1" )  Q"RTN", "PXBAPI21" ,78,0) ..I  $G(PXCECA T)="VST",T YPI=7,($P( $G(^AUPNVS IT(PXVST,8 00)),U,17) ="1")  Q"R TN","PXBAP I21",79,0)  ..I $G(PX CECAT)="VS T",TYPI=8, ($P($G(^AU PNVSIT(PXV ST,800)),U ,18)="1")   Q"RTN","P XBAPI21",8 0,0) ..;   djs PX*1.0 *207  RSD  SPEC #2.6. 2.4.2.1 &  2.6.2.4.3. 1  Add che ck for Cam p Lejeune  and CLV Ed it Flag"RT N","PXBAPI 21",81,0)  ..I $G(PXC ECAT)="VST ",TYPI=9,( $P($G(^AUP NVSIT(PXVS T,800)),U, 19)="1")   Q"RTN","PX BAPI21",82 ,0) ..D ON E^PXBAPI22 (TYPI,SDCL OEY(TYPI), ENCOWNTR,. SQUIT)"RTN ","PXBAPI2 1",83,0) . .;  djs PX *1.0*207   RSD SPEC # 2.6.2.4.2. 1 & 2.6.2. 4.3.1  Add  processin g for Camp  Lejeune a nd Service  Connected "RTN","PXB API21",84, 0) ..I TYP I=3 F I=1, 2,4,9 S:$D (SDCLOEY(I ))&($P($G( PXBDATA(3) ),"^",2)=1 ) $P(SDCLO EY(I),"^", 3)=1 S:$P( $G(PXBDATA (3)),"^",2 )=0&('$D(S DCLOEY(I)) ) SDCLOEY( I)="""RTN" ,"PXBAPI21 ",85,0) I  $P($G(PXBD ATA(3)),"^ ",2)'="" D "RTN","PXB API21",86, 0) .N END" RTN","PXBA PI21",87,0 ) .S END=0 "RTN","PXB API21",88, 0) .F CTS= 1:1 S TYPI =+$P(TYPSE Q,",",CTS)  Q:'TYPI   I TYPI'=3  D"RTN","PX BAPI21",89 ,0) ..I $P ($G(PXBDAT A(TYPI))," ^",2)'=""  S END=1 Q" RTN","PXBA PI21",90,0 ) .I 'END  H 1"RTN"," PXBAPI21", 91,0) Q"RT N","PXBAPI 21",92,0)E NCHK(ENCOW NTR,X0) ;D o outpatie nt encount er checks" RTN","PXBA PI21",93,0 ) S APTDT= +X0,DFN=$P (X0,"^",2) ,LOC=$P(X0 ,"^",4),OR G=$P(X0,"^ ",8),DA=$P (X0,"^",9) "RTN","PXB API21",94, 0) I +$G(V ADM(6)),+$ G(VADM(6)) <APTDT D   K DIR I $D (DIRUT) S  (PXDOD,END )=1 Q"RTN" ,"PXBAPI21 ",95,0) .  S DIR(0)=" E",DIR("A" )="Enter R ETURN to c ontinue or  '^' to Qu it""RTN"," PXBAPI21", 96,0) . S  DIR("A",2) ="WARNING  "_VADM(7), DIR("A",1) =" ",DIR(" A",3)=" "  D ^DIR"RTN ","PXBAPI2 1",97,0) I  $$REQ^SDM 1A(+X0)'=" CO" S END= 1 Q  ;Chec k MAS Chec k out date  parameter "RTN","PXB API21",98, 0) I ORG=1 ,'$$CLINIC ^SDAMU(+LO C) S END=1  Q  ;Scree n for vali d clinic"R TN","PXBAP I21",99,0)  I "^1^2^" [("^"_ORG_ "^"),$$INP ^SDAM2(+DF N,+X0)="I"  S END=1 Q   ;Inpat c hk"RTN","P XBAPI21",1 00,0) I $$ EXOE^SDCOU 2(ENCOWNTR ) S END=1  Q  ;Chk ex empt Outpt  classific ations"RTN ","PXBAPI2 1",101,0)  Q"RTN","PX BAPI21",10 2,0)OPCHK( DFN,LOC,AP TDT) ;Do s tandalone  outpatient  encounter  checks"RT N","PXBAPI 21",103,0)  I +$G(VAD M(6)),+$G( VADM(6))<A PTDT D  K  DIR I $D(D IRUT) S (P XDOD,END)= 1 Q"RTN"," PXBAPI21", 104,0) . S  DIR(0)="E ",DIR("A") ="Enter RE TURN to co ntinue or  '^' to Qui t""RTN","P XBAPI21",1 05,0) . S  DIR("A",2) ="WARNING  "_VADM(7), DIR("A",1) =" ",DIR(" A",3)=" "  D ^DIR"RTN ","PXBAPI2 1",106,0)  I $$REQ^SD M1A(APTDT) '="CO" S E ND=1 Q  ;C heck MAS C heck out d ate parame ter"RTN"," PXBAPI21", 107,0) I ' $$CLINIC^S DAMU(+LOC)  S END=1 Q   ;Screen  for valid  clinic"RTN ","PXBAPI2 1",108,0)  I $$INP^SD AM2(+DFN,A PTDT)="I"  S END=1 Q   ;Inpat ch k"RTN","PX BAPI21",10 9,0) Q"RTN ","PXBAPI2 1",110,0)T EST ;Test  call to CL ASS"RTN"," PXBAPI21", 111,0) N P XIFN S PXI FN=63"RTN" ,"PXBAPI21 ",112,0) F   S PXIFN= $O(^SCE(PX IFN)) Q:PX IFN<1  S D FN=$P(^(PX IFN,0),"^" ,2) K PXBD ATA W !!,P XIFN_"   " _$P(^DPT(D FN,0),"^")  D  S %=1  W !,"Conti nue " D YN ^DICN Q:%' =1"RTN","P XBAPI21",1 13,0) . D  CLASS(PXIF N)"RTN","P XBAPI21",1 14,0) . ;W  ! ZW PXBD ATA"RTN"," PXBAPI21", 115,0) Q"R TN","PXBAP I22")0^35^ B10766424" RTN","PXBA PI22",1,0) PXBAPI22 ; ISL/DCM -  API for Cl assificati on check o ut ;16 Oct  2006  9:4 2 PM"RTN", "PXBAPI22" ,2,0) ;;1. 0;PCE PATI ENT CARE E NCOUNTER;* *1,26,184, 168,207**; Aug 12, 19 96;Build 5 4"RTN","PX BAPI22",3, 0)ONE(TYPI ,DATA,ENCO WNTR,SQUIT ) ;Process  One Class ification" RTN","PXBA PI22",4,0)  ; Input   -- TYPI     Outpatien t Classifi cation Typ e IEN"RTN" ,"PXBAPI22 ",5,0) ;            D ATA    Nul l or 409.4 2 IEN^Inte rnal Value ^1=n/a^1=u nedt"RTN", "PXBAPI22" ,6,0) ;            EN COWNTR      Outpatien t Encounte r file IEN  (optional )"RTN","PX BAPI22",7, 0) ; Outpu t -- SQUIT  User ente red '^' or  timeout"R TN","PXBAP I22",8,0)  N SDCT0,SD VAL"RTN"," PXBAPI22", 9,0) S SDC T0=$G(^SD( 409.41,TYP I,0)) I SD CT0']"" S  PXBDATA("E RR",TYPI)= 1 Q  ;Bad  entry"RTN" ,"PXBAPI22 ",10,0) I  $P(DATA,"^ ",3) D:DAT A  S PXBDA TA("ERR",T YPI)=2 Q   ;Not appli cable"RTN" ,"PXBAPI22 ",11,0) .W  !,$C(7)," >>> "_$P(S DCT0,"^",6 )_" is no  longer app licable... ""RTN","PX BAPI22",12 ,0) .S DA= +DATA,DIK= "^SDD(409. 42," D ^DI K W "delet ed.""RTN", "PXBAPI22" ,13,0) I D ATA,$P(DAT A,"^",4) D   S PXBDAT A("ERR",TY PI)=3 Q  ; Uneditable  data"RTN" ,"PXBAPI22 ",14,0) .  W !,$P(SDC T0,"^",6)_ ": "_$$VAL ^SDCODD(TY PI,$P(DATA ,"^",2))_"   <Unedita ble>""RTN" ,"PXBAPI22 ",15,0) S  SDVAL=$$VA L(TYPI,SDC T0,DATA) ; Get field  value"RTN" ,"PXBAPI22 ",16,0) I  SDVAL="^"  S SQUIT="" ,PXBDATA(" ERR",TYPI) =4 Q  ;use r ^ out"RT N","PXBAPI 22",17,0)  D STORE(+D ATA,SDVAL, TYPI)"RTN" ,"PXBAPI22 ",18,0) Q" RTN","PXBA PI22",19,0 )VAL(TYPI, SDCT0,DATA ) ;Get Out patient Cl assificati on"RTN","P XBAPI22",2 0,0) N DIR ,DA,Y,SDXS ,SDEF"RTN" ,"PXBAPI22 ",21,0) I  TYPI=1,$P( $G(^DPT(DF N,.321))," ^",2)'="Y" !($P($G(^D PT(DFN,.32 1)),"^",13 )'="V") G  VALQ"RTN", "PXBAPI22" ,22,0) I T YPI=2,$P($ G(^DPT(DFN ,.321)),"^ ",3)'="Y"  G VALQ"RTN ","PXBAPI2 2",23,0) I  TYPI=4,$P ($G(^DPT(D FN,.322)), "^",13)'=" Y",'$$EC^S DCO22(DFN, ENCOWNTR)  G VALQ"RTN ","PXBAPI2 2",24,0) I  TYPI=9,$P ($G(^DPT(D FN,.3217)) ,"^",1)'=" Y" G VALQ   ;Added Ca mp Lejeune  PX*1.0*20 7 JLS RSD  SPEC #2.6. 2.4.2.1 &  2.6.2.4.3. 1"RTN","PX BAPI22",25 ,0) I TYPI =3,$P($G(^ SCE(+$G(EN COWNTR),0) ),"^",10)= 2 S Y=1 G  VALQ ;Chan ge SC to ' yes'"RTN", "PXBAPI22" ,26,0) ;   djs  PX*1. 0*207  RSD  SPEC #2.6 .2.3  Corr ects displ ay of Camp  Lejeune h elp text b elow"RTN", "PXBAPI22" ,27,0) D F ULL0^PXBCC "RTN","PXB API22",28, 0) ;Automa tion of th e SC respo nse"RTN"," PXBAPI22", 29,0) I TY PI=3,(+$G( PXD)!(+$G( PXDX))) D   I Y'="",' $G(SDSCEDI T) G VALQ" RTN","PXBA PI22",30,0 ) .S SDXS( $S(+$G(PXD ):+PXD,1:+ $G(PXDX))) ="""RTN"," PXBAPI22", 31,0) .S Y =$$SC^SDSC API(DFN,.S DXS,ENCOWN TR,$G(VISI T)) Q:Y="" "RTN","PXB API22",32, 0) .S Y=+Y ,SDEF=$S(Y :"YES",1:" NO")"RTN", "PXBAPI22" ,33,0) .I  '$G(SDSCED IT) D"RTN" ,"PXBAPI22 ",34,0) .. W !,$S($P( SDCT0,"^", 2)]"":$P(S DCT0,"^",2 ),1:$P(SDC T0,"^"))," ? ""RTN"," PXBAPI22", 35,0) ..W  $S(Y:"YES" ,1:"NO")"R TN","PXBAP I22",36,0) REASK S DI R("A")=$S( $P(SDCT0," ^",2)]"":$ P(SDCT0,"^ ",2),1:$P( SDCT0,"^") )"RTN","PX BAPI22",37 ,0) I $P(D ATA,"^",2) ]""!($P(SD CT0,"^",4) ]"") S DIR ("B")=$S($ D(SDEF):SD EF,$P(DATA ,"^",2)]"" :$$VAL^SDC ODD(TYPI,$ P(DATA,"^" ,2)),1:$P( SDCT0,"^", 4))"RTN"," PXBAPI22", 38,0) S DI R(0)=$P(SD CT0,"^",3) _"O" S:$D( SDEF) DIR( "B")=SDEF" RTN","PXBA PI22",39,0 ) I $D(^SD (409.41,TY PI,2)) S D IR(0)=DIR( 0)_"^"_^(2 )"RTN","PX BAPI22",40 ,0) I TYPI =3 S DIR(" ?")="^D SC ^SDCO23(DF N)""RTN"," PXBAPI22", 41,0) ;  d js  PX*1.0 *207  RSD  SPEC #2.6. 2.3  Added  help text  for quest ion about  Camp Lejeu ne"RTN","P XBAPI22",4 2,0) I TYP I=9 D"RTN" ,"PXBAPI22 ",43,0) .S  DIR("?",1 )="For thi s Veteran,  enter ""Y "" if the  treatment  for this e ncounter,  visit,""RT N","PXBAPI 22",44,0)  .S DIR("?" ,2)="or ad mission is  related t o a Vetera n's Camp L ejeune con dition. En ter ""N""" "RTN","PXB API22",45, 0) .S DIR( "?",3)="if  the treat ment for t his encoun ter, visit , or admis sion is no t related  to""RTN"," PXBAPI22", 46,0) .S D IR("?",4)= "a Veteran 's Camp Le jeune cond ition.""RT N","PXBAPI 22",47,0)  .S DIR("?" ,5)="Choos e from:""R TN","PXBAP I22",48,0)  .S DIR("? ",6)="Y Ye s""RTN","P XBAPI22",4 9,0) .S DI R("?")="N  No""RTN"," PXBAPI22", 50,0) D ^D IR"RTN","P XBAPI22",5 1,0) I $P( SDCT0,"^", 5),'$D(DTO UT),$P(DAT A,"^",2)=" ",Y=""!(Y[ "^"&('$P($ G(^DG(43,1 ,"SCLR")), "^",24)))  D  G REASK "RTN","PXB API22",52, 0) .W !,$C (7),"This  is a requi red respon se." W:Y[" ^" "  An ' ^' is not  allowed."" RTN","PXBA PI22",53,0 ) .K DIRUT ,DUOUT"RTN ","PXBAPI2 2",54,0) I  $D(DIRUT)  S Y="^""R TN","PXBAP I22",55,0) VALQ K DIR UT,DTOUT,D UOUT"RTN", "PXBAPI22" ,56,0) Q $ G(Y)"RTN", "PXBAPI22" ,57,0) ;"R TN","PXBAP I22",58,0) STORE(SDCN I,SDCNV,TY PI) ;File  Outpatient  Classific ation"RTN" ,"PXBAPI22 ",59,0) ;  Input  --  SDCNI    O utpatient  Classifica tion IEN"R TN","PXBAP I22",60,0)  ;            SDCNV     Outpatie nt Classif ication Va lue"RTN"," PXBAPI22", 61,0) ;            TY PI    Clas sification  type 1 -  Agent Oran ge"RTN","P XBAPI22",6 2,0) ;                                            2 -  Ionizing R adiation"R TN","PXBAP I22",63,0)  ;                                            3 - Serv ice Connec ted"RTN"," PXBAPI22", 64,0) ;                                            4 -  SW Asia C onditions" RTN","PXBA PI22",65,0 ) ;                                            9 - Cam p Lejeune" RTN","PXBA PI22",66,0 ) ; Output  -- PXBDAT A array"RT N","PXBAPI 22",67,0)  ; Error co des -- PXB DATA("ERR" ,TYPI)=1 -  Bad ptr t o 409.41 i n TYPI"RTN ","PXBAPI2 2",68,0) ;                                      2 - DA TA entry n ot applica ble"RTN"," PXBAPI22", 69,0) ;                                      3 - DATA  entry uned itable"RTN ","PXBAPI2 2",70,0) ;                                      4 - Us er ^ out o f prompt"R TN","PXBAP I22",71,0)  S PXBDATA (TYPI)=SDC NI_"^"_SDC NV"RTN","P XBAPI22",7 2,0) Q"RTN ","PXBDCPT ")0^32^B52 472938"RTN ","PXBDCPT ",1,0)PXBD CPT ;ISL/J VS,ESW - D ISPLAY CPT  ;24 May 2 013  10:44  AM"RTN"," PXBDCPT",2 ,0) ;;1.0; PCE PATIEN T CARE ENC OUNTER;**1 1,73,89,10 8,121,124, 199,207**; Aug 12, 19 96;Build 5 4"RTN","PX BDCPT",3,0 ) ;"RTN"," PXBDCPT",4 ,0) ; Refe rence to L D^ICDEX su pported by  ICR #5747 "RTN","PXB DCPT",5,0)  ;"RTN","P XBDCPT",6, 0)EN0 ;--- Main entry  point"RTN ","PXBDCPT ",7,0) ;"R TN","PXBDC PT",8,0) ; "RTN","PXB DCPT",9,0) HEAD ;--HE ADER ON LI ST"RTN","P XBDCPT",10 ,0) S HEAD ="- - E N  C O U N T  E R  P R O  C E D U R  E S (CPT  CODES) - - ""RTN","PX BDCPT",11, 0) W IOINH I,!,IOCUU, ?(IOM-$L(H EAD))\2,HE AD,IOINLOW "RTN","PXB DCPT",12,0 ) W IOELEO L K HEAD"R TN","PXBDC PT",13,0)  ;"RTN","PX BDCPT",14, 0) I $D(CL INIC) D PR V^PXBUTL2( CLINIC)"RT N","PXBDCP T",15,0) ; "RTN","PXB DCPT",16,0 ) ;I PXBCN T<11 D DIS CPT1^PXBDC PT"RTN","P XBDCPT",17 ,0) ;I PXB CNT<21&(PX BCNT>10) D  DISCPT2^P XBDCPT"RTN ","PXBDCPT ",18,0) ;I  PXBCNT>20 &(PXBCNT<3 1) D DISCP T3^PXBDCPT "RTN","PXB DCPT",19,0 ) ;I PXBCN T>30&('$D( PXBNCPT))" RTN","PXBD CPT",20,0)  D DISCPT4 ^PXBDCPT(" BEGIN")"RT N","PXBDCP T",21,0) ; I PXBCNT>3 0&($D(PXBN CPT)) D DI SCPT4^PXBD CPT("SAME" )"RTN","PX BDCPT",22, 0) Q"RTN", "PXBDCPT", 23,0) ;"RT N","PXBDCP T",24,0) ; "RTN","PXB DCPT",25,0 ) ;"RTN"," PXBDCPT",2 6,0)ARRAY  ;Set all C PT codes a nd modifie rs into ^T MP("PXBDCP T",$J,"DSP ""RTN","PX BDCPT",27, 0) ;for di splay"RTN" ,"PXBDCPT" ,28,0) ;"R TN","PXBDC PT",29,0)  N PXSQ,ENT RY,PXMD,PX DESC,PX124 ,PXC,PXD,P XDXDATE"RT N","PXBDCP T",30,0) S  PXTMP="^T MP(""PXBDC PT"""_","_ $J_","_""" DSP"")""RT N","PXBDCP T",31,0) K  @PXTMP"RT N","PXBDCP T",32,0) S  (PXTLNS,P XSQ)=0"RTN ","PXBDCPT ",33,0) F   S PXSQ=$O (PXBSAM(PX SQ)) Q:'PX SQ  D"RTN" ,"PXBDCPT" ,34,0) .S  PXTLNS=PXT LNS+1"RTN" ,"PXBDCPT" ,35,0) .S  ENTRY=PXBS AM(PXSQ)"R TN","PXBDC PT",36,0)  .S PXBSAM( PXSQ,"LINE ")=PXTLNS" RTN","PXBD CPT",37,0)  .I $D(PXB NCPT($P(EN TRY,U))) D "RTN","PXB DCPT",38,0 ) ..;I PXB NCPT($P(EN TRY,U))]"" ,'$D(PXBSK Y(PXSQ,PXB NCPT($P(EN TRY,U))))  Q"RTN","PX BDCPT",39, 0) ..Q:'$D (PXBNCPT($ P(ENTRY,U) ,$O(PXBSKY (PXSQ,0))) )"RTN","PX BDCPT",40, 0) ..S $P( ENTRY,U)=$ P(ENTRY,U) _"*""RTN", "PXBDCPT", 41,0) .S @ PXTMP@(PXT LNS,0)=PXS Q_U_$P(ENT RY,U)_U_$P (ENTRY,U,2 )_U_$P(ENT RY,U,4)_U_ $E($P(ENTR Y,U,3),1,2 4)"RTN","P XBDCPT",42 ,0) .S PXM D="""RTN", "PXBDCPT", 43,0) .F   S PXMD=$O( PXBSAM(PXS Q,"MOD",PX MD)) Q:'PX MD  D"RTN" ,"PXBDCPT" ,44,0) ..S  PXTLNS=PX TLNS+1"RTN ","PXBDCPT ",45,0) .. S PXMOD=PX BSAM(PXSQ, "MOD",PXMD )"RTN","PX BDCPT",46, 0) ..S PXD ESC=$P($$M ODP^ICPTMO D($E(ENTRY ,1,5),PXMO D,"E",IDAT E),U,2) ;P X*108"RTN" ,"PXBDCPT" ,47,0) ..S  @PXTMP@(P XTLNS,0)=0 _U_PXMOD_U _$E(PXDESC ,1,54)"RTN ","PXBDCPT ",48,0) .S  PXTLNS=PX TLNS+1"RTN ","PXBDCPT ",49,0) .S  @PXTMP@(P XTLNS,0)=" -22^"_$P(E NTRY,U,22) "RTN","PXB DCPT",50,0 ) .S PXDXD ATE=$$CSDA TE^PXDXUTL (PXBVST)"R TN","PXBDC PT",51,0)  .F PX124=5 :1:12 D"RT N","PXBDCP T",52,0) . .S PXC=$P( ENTRY,U,PX 124) Q:PXC ="""RTN"," PXBDCPT",5 3,0) ..S P XD=$$ICDDA TA^ICDXCOD E("DIAG",P XC,PXDXDAT E,"E") Q:P XD<1"RTN", "PXBDCPT", 54,0) ..I  $P(PXD,U,2 0)'=30 D"R TN","PXBDC PT",55,0)  ...S PXC=P XC_"    "_ $P(PXD,U,4 )"RTN","PX BDCPT",56, 0) ...S PX TLNS=PXTLN S+1,@PXTMP @(PXTLNS,0 )=-PX124_U _PXC"RTN", "PXBDCPT", 57,0) ..I  $P(PXD,U,2 0)=30 D"RT N","PXBDCP T",58,0) . ..N PXENTR Y S PXENTR Y(1)=$$SEN TENCE^XLFS TR($$LD^IC DEX(80,$P( PXD,U,1),P XDXDATE))" RTN","PXBD CPT",59,0)  ...D PR^P XSELDS(.PX ENTRY,50)" RTN","PXBD CPT",60,0)  ...N PXLE NGTH,PXLON G,PXSPACES  S PXSPACE S="     ", PXLENGTH=$ L(PXC)-5"R TN","PXBDC PT",61,0)  ...I PXLEN GTH>0 S PX SPACES=$E( PXSPACES,1 ,5-PXLENGT H)"RTN","P XBDCPT",62 ,0) ...S P XLONG=PXC_ PXSPACES_P XENTRY(1)" RTN","PXBD CPT",63,0)  ...S PXTL NS=PXTLNS+ 1,@PXTMP@( PXTLNS,0)= -PX124_U_P XLONG"RTN" ,"PXBDCPT" ,64,0) ... N PXNUMBR  F PXNUMBR= 2:1:PXENTR Y D"RTN"," PXBDCPT",6 5,0) ....S  PXTLNS=PX TLNS+1,@PX TMP@(PXTLN S,0)=-PX12 4_U_PXENTR Y(PXNUMBR) _U_"NEXTLO NG""RTN"," PXBDCPT",6 6,0) ..I $ G(PXBREQ(+ PXD,"I"))= "" S PXBRE Q(+PXD,"I" )=$P($$XLA TE^PXBGPOV (PXBVST,+P XD),U,4,20 )"RTN","PX BDCPT",67, 0) ..S PXT LNS=PXTLNS +1,@PXTMP@ (PXTLNS,0) ="I^"_PXBR EQ(+PXD,"I ")"RTN","P XBDCPT",68 ,0) Q"RTN" ,"PXBDCPT" ,69,0)DISC PT1 ;--Dis play the C PT Data"RT N","PXBDCP T",70,0) ; "RTN","PXB DCPT",71,0 ) N ENTRY, J"RTN","PX BDCPT",72, 0) D UNDON ^PXBCC"RTN ","PXBDCPT ",73,0) W  !,"No.",?4 ,"CPT CODE ",?14,"QUA NTITY",?25 ,"DESCRIPT ION",?55," PROVIDER", ?75,$C(32) "RTN","PXB DCPT",74,0 ) W IOEDEO P"RTN","PX BDCPT",75, 0) D UNDOF F^PXBCC"RT N","PXBDCP T",76,0) ; "RTN","PXB DCPT",77,0 ) ;"RTN"," PXBDCPT",7 8,0) S J=0 "RTN","PXB DCPT",79,0 ) F  S J=$ O(PXBSAM(J )) Q:J=""   D"RTN","P XBDCPT",80 ,0) .S ENT RY=$G(PXBS AM(J))"RTN ","PXBDCPT ",81,0) .I  $D(PXBNCP T($P(ENTRY ,U,1))) S  $P(ENTRY,U ,1)=$P(ENT RY,U,1)_"* ""RTN","PX BDCPT",82, 0) .W !,J, ?4,$P(ENTR Y,U,1),?15 ,$P(ENTRY, U,2)"RTN", "PXBDCPT", 83,0) .W ? 25,$P(ENTR Y,U,4),?55 ,$E($P(ENT RY,U,3),1, 24)"RTN"," PXBDCPT",8 4,0) .;--- Display as sociated m odifiers"R TN","PXBDC PT",85,0)  .S PXSIEN= """RTN","P XBDCPT",86 ,0) .F  S  PXSIEN=$O( PXBSAM(J," MOD",PXSIE N)) Q:PXSI EN=""  D"R TN","PXBDC PT",87,0)  ..N PXWRAP ,PXMOD,PXD ESC,PXLN"R TN","PXBDC PT",88,0)  ..S PXMOD= PXBSAM(J," MOD",PXSIE N)"RTN","P XBDCPT",89 ,0) ..S PX DESC=$P($$ MOD^ICPTMO D(PXMOD,"E ",IDATE),U ,3)"RTN"," PXBDCPT",9 0,0) ..D W RAP^PXCEVF I4(PXDESC, 58,.PXWRAP )"RTN","PX BDCPT",91, 0) ..F PXL N=1:1 Q:$G (PXWRAP(PX LN))=""  D "RTN","PXB DCPT",92,0 ) ...W:PXL N=1 !,?4," CPT Modifi er: "_PXMO D"RTN","PX BDCPT",93, 0) ...W:PX LN>1 !"RTN ","PXBDCPT ",94,0) .. .W ?22,PXW RAP(PXLN)" RTN","PXBD CPT",95,0)  ;---Write  no entrie s if none  exist"RTN" ,"PXBDCPT" ,96,0) I ' $D(PXBSAM)  D NONE^PX BUTL(2)"RT N","PXBDCP T",97,0) Q "RTN","PXB DCPT",98,0 ) ;"RTN"," PXBDCPT",9 9,0)DISCPT 2 ;--displ ay of cpt  data two c olumns if  more than  10 entries ."RTN","PX BDCPT",100 ,0) ;"RTN" ,"PXBDCPT" ,101,0) N  ENTRY,J,PX A"RTN","PX BDCPT",102 ,0) D GSET ^%ZISS"RTN ","PXBDCPT ",103,0) D  UNDON^PXB CC W IOG1" RTN","PXBD CPT",104,0 ) W !,"NO" ,?4,"CPT", ?10,"QUA", ?14,"DESCR IPTION",?3 9,IOVL"RTN ","PXBDCPT ",105,0) W  ?40,"NO", ?44,"CPT", ?50,"QUA", ?54,"NARRA TIVE""RTN" ,"PXBDCPT" ,106,0) W  IOEDEOP"RT N","PXBDCP T",107,0)  D UNDOFF^P XBCC"RTN", "PXBDCPT", 108,0) ;"R TN","PXBDC PT",109,0)  ;"RTN","P XBDCPT",11 0,0) ;"RTN ","PXBDCPT ",111,0) S  J=0 F  S  J=$O(PXBSA M(J)) Q:J= ""  D"RTN" ,"PXBDCPT" ,112,0) .S  ENTRY(J)= $G(PXBSAM( J)) I $D(P XBNCPT($P( ENTRY(J),U ,1))) S $P (ENTRY(J), U,1)=$P(EN TRY(J),U,1 )_"*""RTN" ,"PXBDCPT" ,113,0) F  J=1:1:10 D "RTN","PXB DCPT",114, 0) .W !,J, ?4,$P(ENTR Y(J),U,1), ?11,$P(ENT RY(J),U,2) ,?14,$E($P (ENTRY(J), U,4),1,24) "RTN","PXB DCPT",115, 0) .D BAWR ITE(ENTRY( J))"RTN"," PXBDCPT",1 16,0) .I $ D(ENTRY(J+ 10)) D"RTN ","PXBDCPT ",117,0) . .W ?39,IOV L,(J+10),? 44,$P(ENTR Y(J+10),U, 1),?51,$P( ENTRY(J+10 ),U,2),?54 ,$E($P(ENT RY(J+10),U ,4),1,24)" RTN","PXBD CPT",118,0 ) ..D BAWR ITE(ENTRY( J))"RTN"," PXBDCPT",1 19,0) W IO G0"RTN","P XBDCPT",12 0,0) Q"RTN ","PXBDCPT ",121,0) ; "RTN","PXB DCPT",122, 0)DISCPT3  ;--display  of cpt da ta three c olumns if  more than  20 entries ."RTN","PX BDCPT",123 ,0) N ENTR Y,J,PXA"RT N","PXBDCP T",124,0)  D GSET^%ZI SS"RTN","P XBDCPT",12 5,0) D UND ON^PXBCC W  IOG1"RTN" ,"PXBDCPT" ,126,0) W  !,"NO",?4, "CPT",?10, "QUA",?14, "NARRATIVE ",?25,IOVL "RTN","PXB DCPT",127, 0) W ?26," NO",?30,"C PT",?36,"Q UA",?40,"N ARRATIVE", ?51,IOVL"R TN","PXBDC PT",128,0)  W ?52,"NO ",?56,"CPT ",?62,"QUA ",?66,"NAR RATIVE""RT N","PXBDCP T",129,0)  W IOEDEOP" RTN","PXBD CPT",130,0 ) D UNDOFF ^PXBCC"RTN ","PXBDCPT ",131,0) ; "RTN","PXB DCPT",132, 0) S J=0 F   S J=$O(P XBSAM(J))  Q:J=""  D" RTN","PXBD CPT",133,0 ) .S ENTRY (J)=$G(PXB SAM(J)) I  $D(PXBNCPT ($P(ENTRY( J),U,1)))  S $P(ENTRY (J),U,1)=$ P(ENTRY(J) ,U,1)_"*"" RTN","PXBD CPT",134,0 ) F J=1:1: 10 D"RTN", "PXBDCPT", 135,0) .W  !,J,?4,$P( ENTRY(J),U ,1),?11,$P (ENTRY(J), U,2),?14,$ E($P(ENTRY (J),U,4),1 ,10)"RTN", "PXBDCPT", 136,0) .D  BAWRITE(EN TRY(J))"RT N","PXBDCP T",137,0)  .I $D(ENTR Y(J+10)) D "RTN","PXB DCPT",138, 0) ..W ?25 ,IOVL,(J+1 0),?30,$P( ENTRY(J+10 ),U,1),?37 ,$P(ENTRY( J+10),U,2) ,?40,$E($P (ENTRY(J+1 0),U,4),1, 10)"RTN"," PXBDCPT",1 39,0) ..D  BAWRITE(EN TRY(J+10)) "RTN","PXB DCPT",140, 0) .I $D(E NTRY(J+20) ) D"RTN"," PXBDCPT",1 41,0) ..W  ?51,IOVL,( J+20),?56, $P(ENTRY(J +20),U,1), ?63,$P(ENT RY(J+20),U ,2),?66,$E ($P(ENTRY( J+20),U,4) ,1,10)"RTN ","PXBDCPT ",142,0) . .D BAWRITE (ENTRY(J+2 0))"RTN"," PXBDCPT",1 43,0) W IO G0"RTN","P XBDCPT",14 4,0) Q"RTN ","PXBDCPT ",145,0) ; "RTN","PXB DCPT",146, 0)DISCPT4( SIGN) ;--D isplay the  CPT Data" RTN","PXBD CPT",147,0 ) ;"RTN"," PXBDCPT",1 48,0) ;SIG N="RTN","P XBDCPT",14 9,0) ; '+'  add 10 to  the start ing point  in ^TMP("P XBDCPT",$J )"RTN","PX BDCPT",150 ,0) ; '-'  subtract 1 0 from the  starting  point but  not less t han 0"RTN" ,"PXBDCPT" ,151,0) ;  'BEGIN' st art at the  beginning "RTN","PXB DCPT",152, 0) ; 'SAME ' start st ays where  it's at"RT N","PXBDCP T",153,0)  ; '3'--any  number se t start to  that numb er"RTN","P XBDCPT",15 4,0) ;"RTN ","PXBDCPT ",155,0) N  PXBSTART, PXTMP"RTN" ,"PXBDCPT" ,156,0) D  ARRAY"RTN" ,"PXBDCPT" ,157,0) I  SIGN="BEGI N" S ^TMP( "PXBDCPT", $J,"START" )=0,PXBSTA RT=0"RTN", "PXBDCPT", 158,0) I S IGN="SAME"  S PXBSTAR T=^TMP("PX BDCPT",$J, "START")"R TN","PXBDC PT",159,0)  I SIGN="+ " D"RTN"," PXBDCPT",1 60,0) .S P XBSTART=($ G(^TMP("PX BDCPT",$J, "START"))+ 10)"RTN"," PXBDCPT",1 61,0) .I P XBSTART'<P XTLNS S PX BSTART=PXB START-10"R TN","PXBDC PT",162,0)  .S ^TMP(" PXBDCPT",$ J,"START") =PXBSTART" RTN","PXBD CPT",163,0 ) I SIGN=" -" D"RTN", "PXBDCPT", 164,0) .S  PXBSTART=$ G(^TMP("PX BDCPT",$J, "START"))- 10"RTN","P XBDCPT",16 5,0) .S ^T MP("PXBDCP T",$J,"STA RT")=PXBST ART"RTN"," PXBDCPT",1 66,0) .I P XBSTART<0  S PXBSTART =0 S ^TMP( "PXBDCPT", $J,"START" )=0"RTN"," PXBDCPT",1 67,0) I +S IGN>0&(SIG N#10) D  Q :^TMP("PXB DCPT",$J," START")=PX BSTART  S  ^TMP("PXBD CPT",$J,"S TART")=PXB START"RTN" ,"PXBDCPT" ,168,0) .S  PXBSTART= $P((SIGN/1 0),".")*10 "RTN","PXB DCPT",169, 0) .S:PXBS TART<10 PX BSTART=0"R TN","PXBDC PT",170,0)  I +SIGN>0 &'(SIGN#10 ) D  Q:^TM P("PXBDCPT ",$J,"STAR T")=PXBSTA RT  S ^TMP ("PXBDCPT" ,$J,"START ")=PXBSTAR T"RTN","PX BDCPT",171 ,0) .S PXB START=(($P ((SIGN/10) ,".")*10)- 10)"RTN"," PXBDCPT",1 72,0) .S:P XBSTART<10  PXBSTART= 0"RTN","PX BDCPT",173 ,0) ;"RTN" ,"PXBDCPT" ,174,0) ;" RTN","PXBD CPT",175,0 ) I SIGN'= "BEGIN" D  LOC^PXBCC( 3,0) W IOE DEOP"RTN", "PXBDCPT", 176,0) ;"R TN","PXBDC PT",177,0) HEAD4 ;--H EADER ON L IST"RTN"," PXBDCPT",1 78,0) S HE AD="- - E  N C O U N  T E R  P R  O C E D U  R E S (CP T CODES) -  -""RTN"," PXBDCPT",1 79,0) W IO INHI,!,IOC UU,?(IOM-$ L(HEAD))\2 ,HEAD,IOIN LOW"RTN"," PXBDCPT",1 80,0) W IO ELEOL K HE AD"RTN","P XBDCPT",18 1,0) ;"RTN ","PXBDCPT ",182,0) ; "RTN","PXB DCPT",183, 0) N ENTRY ,J"RTN","P XBDCPT",18 4,0) D UND ON^PXBCC"R TN","PXBDC PT",185,0)  W !,"No." ,?4,"CPT C ODE",?14," QUANTITY", ?25,"DESCR IPTION",?5 5,"PROVIDE R",?75,$C( 32)"RTN"," PXBDCPT",1 86,0) W IO EDEOP"RTN" ,"PXBDCPT" ,187,0) D  UNDOFF^PXB CC"RTN","P XBDCPT",18 8,0) ;"RTN ","PXBDCPT ",189,0) ; "RTN","PXB DCPT",190, 0) N PXSIE N,PXDESC,P XMOD,PXQ,P XLNS,PX,PL "RTN","PXB DCPT",191, 0) S J=PXB START,PXQ= """RTN","P XBDCPT",19 2,0) S PXL NS=0"RTN", "PXBDCPT", 193,0) F   S J=$O(@PX TMP@(J)) Q :J=""  D   Q:PXQ"RTN" ,"PXBDCPT" ,194,0) .S  PXLNS=PXL NS+1"RTN", "PXBDCPT", 195,0) .I  '(PXLNS#11 ) D  Q"RTN ","PXBDCPT ",196,0) . .S ^TMP("P XBDCPT",$J ,"START")= PXBSTART"R TN","PXBDC PT",197,0)  ..S PXQ=1 "RTN","PXB DCPT",198, 0) .I +@PX TMP@(J,0)> 0 D  Q"RTN ","PXBDCPT ",199,0) . .W !,$P(^( 0),U),?4,$ P(^(0),U,2 ),?15,$P(^ (0),U,3)"R TN","PXBDC PT",200,0)  ..W ?25,$ P(^(0),U,4 ),?55,$P(^ (0),U,5)"R TN","PXBDC PT",201,0)  .I +@PXTM P@(J,0)<0  D  Q"RTN", "PXBDCPT", 202,0) ..S  PX=-$P(^( 0),U,1)"RT N","PXBDCP T",203,0)  ..I PX=22  W !?4,"Ord ering Prov ider:  ",$ P(^(0),U,2 ) Q"RTN"," PXBDCPT",2 04,0) ..I  PX<20,$P(^ (0),U,3)'= "NEXTLONG"  W !?4,"Di agnosis "_ (PX-4)_":   ",$P(^(0) ,U,2) Q"RT N","PXBDCP T",205,0)  ..I PX<20, $P(^(0),U, 3)="NEXTLO NG" W !?28 ,$P(^(0),U ,2)"RTN"," PXBDCPT",2 06,0) .I $ P(@PXTMP@( J,0),U)="I " D CIA^PX BDPOV($P(^ (0),U,2,16 )) Q"RTN", "PXBDCPT", 207,0) .I  $P(@PXTMP@ (J,0),U)=0  D"RTN","P XBDCPT",20 8,0) ..W ! ?4,"CPT Mo difier: "_ $P(^(0),U, 2)_"  "_$P (^(0),U,3) "RTN","PXB DCPT",209, 0) I SIGN' ="BEGIN" W  !!"RTN"," PXBDCPT",2 10,0) Q"RT N","PXBDCP T",211,0)  ;"RTN","PX BDCPT",212 ,0)BAWRITE (PXD) ;WRI TE BA INFO "RTN","PXB DCPT",213, 0) N PX,PD ,PP"RTN"," PXBDCPT",2 14,0) W !? 4,"Orderin g Provider :  ",$P(PX D,U,22)"RT N","PXBDCP T",215,0)  ;  djs  PX *1.0*207   RSD SPEC # 2.6.2.4.5. 3  Increas e FOR loop  for Camp  Lejeune"RT N","PXBDCP T",216,0)  F PX=1:1:9  D"RTN","P XBDCPT",21 7,0) .S PD =$P(PXD,U, PX+5),PP=$ $XLATE^PXB GPOV(PXBVS T,PD)"RTN" ,"PXBDCPT" ,218,0) .Q :'PD!'PP"R TN","PXBDC PT",219,0)  .W:PD !?4 ,"Diagnosi s:  ",PD"R TN","PXBDC PT",220,0)  .D CIA^PX BDPOV($P(P P,U,4,16)) "RTN","PXB DCPT",221, 0) Q"RTN", "PXBDCPT", 222,0) ;"R TN","PXBDP OV")0^7^B3 2861915"RT N","PXBDPO V",1,0)PXB DPOV ;ISL/ JVS - DISP LAY POV (D IAGNOSIS)  ;24 May 20 13  7:02 A M"RTN","PX BDPOV",2,0 ) ;;1.0;PC E PATIENT  CARE ENCOU NTER;**124 ,168,199,2 07**;Aug 1 2, 1996;Bu ild 54"RTN ","PXBDPOV ",3,0) ;"R TN","PXBDP OV",4,0) ; "RTN","PXB DPOV",5,0) EN0 ;---Ma in entry p oint"RTN", "PXBDPOV", 6,0) I '$D (IOCUU) D  TERM^PXBCC "RTN","PXB DPOV",7,0)  ;"RTN","P XBDPOV",8, 0)HEAD ;-- HEADER ON  LIST"RTN", "PXBDPOV", 9,0) S HEA D="- - E N  C O U N T  E R  D I  A G N O S  I S  (ICD  CODES) - - ""RTN","PX BDPOV",10, 0) W !,IOC UU,?(IOM-$ L(HEAD))\2 ,IOINHI,HE AD"RTN","P XBDPOV",11 ,0) W IOIN LOW,IOELEO L K HEAD"R TN","PXBDP OV",12,0)  ;"RTN","PX BDPOV",13, 0) I $D(CL INIC) D PO V^PXBUTL2( CLINIC)"RT N","PXBDPO V",14,0) ; I PXBCNT<1 1 D DPOV1" RTN","PXBD POV",15,0)  ;I PXBCNT >10&($D(PX BNPOV)) D  DPOV4("SAM E")"RTN"," PXBDPOV",1 6,0) ;I PX BCNT>10&(' $D(PXBNPOV )) D DPOV4 ("BEGIN")" RTN","PXBD POV",17,0)  D DPOV4($ S($D(PXBNP OV):"SAME" ,1:"BEGIN" ))"RTN","P XBDPOV",18 ,0) Q"RTN" ,"PXBDPOV" ,19,0) ;"R TN","PXBDP OV",20,0)  ;"RTN","PX BDPOV",21, 0)DPOV1 ;- -Display t he POV Dat a"RTN","PX BDPOV",22, 0) N ENTRY ,K"RTN","P XBDPOV",23 ,0) D UNDO N^PXBCC"RT N","PXBDPO V",24,0) W  !,"No.",? 5,"ICD",?1 4,"DESCRIP TION",?65, "PROBLEM L IST""RTN", "PXBDPOV", 25,0) W IO EDEOP"RTN" ,"PXBDPOV" ,26,0) D U NDOFF^PXBC C"RTN","PX BDPOV",27, 0) ;"RTN", "PXBDPOV", 28,0) ;"RT N","PXBDPO V",29,0) S  (K,J)=0 F   S J=$O(P XBSAM(J))  Q:J=""  D" RTN","PXBD POV",30,0)  .S ENTRY= $G(PXBSAM( J)) I $D(P XBNPOV($P( ENTRY,"^", 1))) S $P( ENTRY,"^", 1)=$P(ENTR Y,"^",1)_" *""RTN","P XBDPOV",31 ,0) .I $P( ENTRY,U)=0  D CIA($P( ENTRY,U,2, 16)) Q"RTN ","PXBDPOV ",32,0) .S  K=K+1"RTN ","PXBDPOV ",33,0) .W  !,K,?4,$J ($P($P(ENT RY,"^",1), ".",1),4), ".",$P($P( ENTRY,"^", 1),".",2), ?14,$E($P( ENTRY,"^", 3),1,30),? 45"RTN","P XBDPOV",34 ,0) .W:$P( ENTRY,"^", 4)["PRI" $ P(ENTRY,"^ ",4)"RTN", "PXBDPOV", 35,0) .I $ P(ENTRY,"^ ",4)["PRI"  W ?71,$P( ENTRY,"^", 5)"RTN","P XBDPOV",36 ,0) .E  W  ?75,$P(ENT RY,"^",5)" RTN","PXBD POV",37,0)  .D DIS"RT N","PXBDPO V",38,0) ; ---Write n o entries  if none ex ist"RTN"," PXBDPOV",3 9,0) I '$D (PXBSAM) D  NONE^PXBU TL(3)"RTN" ,"PXBDPOV" ,40,0) ;-- ---------- -UNCOMMENT  TO LIST C LINIC POV  TO SCREEN- ----"RTN", "PXBDPOV", 41,0) ;D D EF^PXBDPOV ("A")"RTN" ,"PXBDPOV" ,42,0) ;-- ---------- ---------- ---------- ---------- ---------- "RTN","PXB DPOV",43,0 ) D DEF^PX BDPOV("D")  I '$D(FIR ST) K PXBD POV"RTN"," PXBDPOV",4 4,0) Q"RTN ","PXBDPOV ",45,0) ;" RTN","PXBD POV",46,0)  ;"RTN","P XBDPOV",47 ,0) ;"RTN" ,"PXBDPOV" ,48,0)DPOV 4(SIGN) ;- -Display t he PROVIDE R Data"RTN ","PXBDPOV ",49,0) ;" RTN","PXBD POV",50,0)  ;SIGN="RT N","PXBDPO V",51,0) ;  '+' add 1 0 to the s tarting po int in ^TM P("PXBDPOV ",$J)"RTN" ,"PXBDPOV" ,52,0) ; ' -' subtrac t 10 from  the starti ng point b ut not les s than 0"R TN","PXBDP OV",53,0)  ; 'BEGIN'  start at t he beginni ng"RTN","P XBDPOV",54 ,0) ; 'SAM E' start s tays where  it's at"R TN","PXBDP OV",55,0)  ; '3'--any  number se t start to  that numb er"RTN","P XBDPOV",56 ,0) ;"RTN" ,"PXBDPOV" ,57,0) N P XBSTART,PX TMP"RTN"," PXBDPOV",5 8,0) I SIG N="BEGIN"  S ^TMP("PX BDPOV",$J, "START")=0 ,PXBSTART= 0"RTN","PX BDPOV",59, 0) I SIGN= "SAME" S P XBSTART=^T MP("PXBDPO V",$J,"STA RT")"RTN", "PXBDPOV", 60,0) I SI GN="+" S P XBSTART=($ G(^TMP("PX BDPOV",$J, "START"))+ (10)) S:PX BSTART'<PX BCNT PXBST ART=(PXBCN T-(10)) S  ^TMP("PXBD POV",$J,"S TART")=PXB START"RTN" ,"PXBDPOV" ,61,0) I S IGN="-" S  PXBSTART=$ G(^TMP("PX BDPOV",$J, "START"))- 10,^TMP("P XBDPOV",$J ,"START")= PXBSTART I  PXBSTART< 0 S PXBSTA RT=0 S ^TM P("PXBDPOV ",$J,"STAR T")=0"RTN" ,"PXBDPOV" ,62,0) I + SIGN>0&(SI GN#10) S P XBSTART=$P ((SIGN/10) ,".")*10 S :PXBSTART< 10 PXBSTAR T=0  Q:^TM P("PXBDPOV ",$J,"STAR T")=PXBSTA RT  S ^TMP ("PXBDPOV" ,$J,"START ")=PXBSTAR T"RTN","PX BDPOV",63, 0) I +SIGN >0&'(SIGN# 10) S PXBS TART=(($P( (SIGN/10), ".")*10)-1 0) S:PXBST ART<10 PXB START=0 Q: ^TMP("PXBD POV",$J,"S TART")=PXB START  S ^ TMP("PXBDP OV",$J,"ST ART")=PXBS TART"RTN", "PXBDPOV", 64,0) ;"RT N","PXBDPO V",65,0) ; "RTN","PXB DPOV",66,0 ) I SIGN'= "BEGIN" D  LOC^PXBCC( 3,0) W IOE DEOP"RTN", "PXBDPOV", 67,0) ;"RT N","PXBDPO V",68,0)HE AD4 ;--HEA DER ON LIS T"RTN","PX BDPOV",69, 0) S HEAD= "- - E N C  O U N T E  R  D I A  G N O S I  S  (ICD CO DES) - -"" RTN","PXBD POV",70,0)  W !,IOCUU ,?(IOM-$L( HEAD))\2,I OINHI,HEAD  ;----F  W  $C(32) Q: $X=(IOM-(1 ))"RTN","P XBDPOV",71 ,0) W IOIN LOW,IOELEO L K HEAD"R TN","PXBDP OV",72,0)  ;"RTN","PX BDPOV",73, 0) N ENTRY ,J,K"RTN", "PXBDPOV", 74,0) D UN DON^PXBCC" RTN","PXBD POV",75,0)  W !,"No." ,?5,"ICD", ?14,"DESCR IPTION",?6 4,"PROBLEM  LIST""RTN ","PXBDPOV ",76,0) W  IOEDEOP"RT N","PXBDPO V",77,0) D  UNDOFF^PX BCC"RTN"," PXBDPOV",7 8,0) D ARR AY"RTN","P XBDPOV",79 ,0) ;"RTN" ,"PXBDPOV" ,80,0) S J =PXBSTART, K=J"RTN"," PXBDPOV",8 1,0) F  S  J=$O(@PXTM P@(J)) Q:J =""  Q:K=( PXBSTART+1 1)  D"RTN" ,"PXBDPOV" ,82,0) .S  ENTRY=$G(@ PXTMP@(J,0 )),K=K+1"R TN","PXBDP OV",83,0)  .I $P(ENTR Y,U)=0 D C IA($P(ENTR Y,U,2,16))  Q"RTN","P XBDPOV",84 ,0) .N PXN UMBR S PXN UMBR=$P(EN TRY,U)"RTN ","PXBDPOV ",85,0) .S  ENTRY=$P( ENTRY,U,2, 15)"RTN"," PXBDPOV",8 6,0) .I $P (ENTRY,"^" ,1)'="",$D (PXBNCPT($ P(ENTRY,"^ ",1))) S $ P(ENTRY,"^ ",1)=$P(EN TRY,"^",1) _"*""RTN", "PXBDPOV", 87,0) .W ! ,PXNUMBR,? 4,$J($P($P (ENTRY,"^" ,1),".",1) ,4),$S($P( ENTRY,"^", 1)'="":"." ,1:""),$P( $P(ENTRY," ^",1),".", 2),?14,$E( $P(ENTRY," ^",3),1,30 ),?45"RTN" ,"PXBDPOV" ,88,0) .W: $P(ENTRY," ^",4)["PRI " IOINHI,$ P(ENTRY,"^ ",4),IOINL OW"RTN","P XBDPOV",89 ,0) .W ?$P (ENTRY,"^" ,4)["PRI"* 7+53,$P(EN TRY,"^",7) "RTN","PXB DPOV",90,0 ) .I $P(EN TRY,"^",4) ["PRI" W ? 71,$P(ENTR Y,"^",5)"R TN","PXBDP OV",91,0)  .D DIS"RTN ","PXBDPOV ",92,0) I  SIGN'="BEG IN" W !!"R TN","PXBDP OV",93,0)  ;--------- ---UNCOMME NT TO LIST  PROVIDERS  TO SCREEN --------"R TN","PXBDP OV",94,0)  ;D DEF^PXB DPOV("A")" RTN","PXBD POV",95,0)  ;-------- ---------- ---------- ---------- ---------- ---------" RTN","PXBD POV",96,0)  D DEF^PXB DPOV("D")  I '$D(FIRS T) K PXBDP OV"RTN","P XBDPOV",97 ,0) Q"RTN" ,"PXBDPOV" ,98,0) ;"R TN","PXBDP OV",99,0)  ;"RTN","PX BDPOV",100 ,0)DEF(COD E) ;---PRO CESS DEFAU LT LIST OF  DIAGNOSES "RTN","PXB DPOV",101, 0) ; I COD E="D" JUST  SEND DEFA ULT"RTN"," PXBDPOV",1 02,0) ; I  CODE="A" J UST SEND T HE ARRAY O F PROVIDER S"RTN","PX BDPOV",103 ,0) D POV^ PXBUTL2(CL INIC,3)"RT N","PXBDPO V",104,0)  N POV,X,CL NAME,STOP, LIST,NAME, NUMBER"RTN ","PXBDPOV ",105,0) I  '$D(IORC)  D TERM^PX BCC"RTN"," PXBDPOV",1 06,0) I '$ D(CODE) W  !,"SEND PA RAMETER =  TO 'D'efau lt OR 'A'r ray" Q"RTN ","PXBDPOV ",107,0) I  $G(CODE)= "D",$D(PXB PMT("DEF") ) S NAME=$ O(PXBPMT(" DEF",0)) S  PXBDPOV=N AME"RTN"," PXBDPOV",1 08,0) I $G (CODE)="A"  K PXBPMT( "DEF") D"R TN","PXBDP OV",109,0)  .S (POV,S TOP)="" F   S POV=$O( PXBPMT("PO V",POV)) Q :POV=""  Q :STOP=0  D "RTN","PXB DPOV",110, 0) ..I '$D (PXBKY(POV )) S STOP= 0"RTN","PX BDPOV",111 ,0) .I STO P="" Q"RTN ","PXBDPOV ",112,0) . S CLNAME=$ P(^SC(CLIN IC,0),"^", 1)"RTN","P XBDPOV",11 3,0) .S X= "Other ICD  CODES ass ociated wi th "_CLNAM E_" clinic .""RTN","P XBDPOV",11 4,0) .W:PX BCNT<7 ! W  !,?(IOM-$ L(X))/2,IO INHI,X,IOI NLOW K X"R TN","PXBDP OV",115,0)  .S (POV,L IST)="" F   S POV=$O( PXBPMT("PO V",POV)) Q :POV=""  D "RTN","PXB DPOV",116, 0) ..I $D( PXBKY(+POV )) Q"RTN", "PXBDPOV", 117,0) ..S  LIST=LIST _POV_"  "  I $L(LIST, "  ")>2 W  !,?(IOM-$L (LIST))/2, LIST S LIS T="""RTN", "PXBDPOV", 118,0) I $ G(LIST)]""  W !,?(IOM -$L(LIST)) /2,LIST"RT N","PXBDPO V",119,0)  Q"RTN","PX BDPOV",120 ,0) ;"RTN" ,"PXBDPOV" ,121,0)DIS  ;----DISP LAY"RTN"," PXBDPOV",1 22,0) Q"RT N","PXBDPO V",123,0)  I $D(PXBPM T("POV",$P ($P(ENTRY, "^",1),"*" ))) W:PXBC NT>11 IORV ON W ?37,"  --Clinic  Associated --",IORVOF F"RTN","PX BDPOV",124 ,0) Q"RTN" ,"PXBDPOV" ,125,0) ;" RTN","PXBD POV",126,0 )CIA(X) ;C linical In dicator Ab breviation s"RTN","PX BDPOV",127 ,0) ;  djs   PX*1.0*2 07  RSD SP EC #2.6.2. 4.4.1  Add  Camp Leje une indica tor to str ing of ind icator abb reviations  and to FO R loop"RTN ","PXBDPOV ",128,0) N  V,I,CI,CI 2 S CI="SC ^AO^IR^EC^ MST^HNC^CV ^SHAD^CL", CI2=1 W !" RTN","PXBD POV",129,0 ) F I=1,7, 2:1:4,8,5, 6,9 S V=$P (X,U,I) I  V]"" W ?(C I2*8),$P(C I,U,I),":" ,$S(V:"Y", 1:"N") S C I2=CI2+1"R TN","PXBDP OV",130,0)  Q"RTN","P XBDPOV",13 1,0) ;"RTN ","PXBDPOV ",132,0)AR RAY ;Set P OV entries  into ^TMP ("PXBDPOV" ,$J,"DSP"  for displa y"RTN","PX BDPOV",133 ,0) N ENTR Y,PX124,PX TLNS"RTN", "PXBDPOV", 134,0) S P XTMP="^TMP (""PXBDPOV """_","_$J _","_"""DS P"")",(PXT LNS,PX124) =0"RTN","P XBDPOV",13 5,0) K @PX TMP"RTN"," PXBDPOV",1 36,0) F  S  PX124=$O( PXBSAM(PX1 24)) Q:'PX 124  D"RTN ","PXBDPOV ",137,0) . S PXTLNS=P XTLNS+1,EN TRY=PXBSAM (PX124)"RT N","PXBDPO V",138,0)  .S PXBSAM( PX124,"LIN E")=PXTLNS "RTN","PXB DPOV",139, 0) .N PXCO DSET S PXC ODSET=$P($ $ICDDATA^I CDXCODE("D IAG",$P(EN TRY,U),$$C SDATE^PXDX UTL(PXBVST ),"E"),U,2 0) I PXCOD SET=30 D"R TN","PXBDP OV",140,0)  ..N PXENT RY S PXENT RY(1)=$P(E NTRY,U,6)  D PR^PXSEL DS(.PXENTR Y,30)"RTN" ,"PXBDPOV" ,141,0) .. S $P(ENTRY ,U,3)=$$SE NTENCE^XLF STR(PXENTR Y(1))"RTN" ,"PXBDPOV" ,142,0) .. S @PXTMP@( PXTLNS,0)= PX124_U_EN TRY"RTN"," PXBDPOV",1 43,0) ..N  PXENTNUM F  PXENTNUM= 2:1:PXENTR Y D"RTN"," PXBDPOV",1 44,0) ...S  ENTRY=U_U _$$SENTENC E^XLFSTR(P XENTRY(PXE NTNUM)),PX TLNS=PXTLN S+1"RTN"," PXBDPOV",1 45,0) ...S  @PXTMP@(P XTLNS,0)=U _ENTRY"RTN ","PXBDPOV ",146,0) . I PXCODSET '=30 S @PX TMP@(PXTLN S,0)=PX124 _U_ENTRY"R TN","PXBDP OV",147,0)  .S PXTLNS =PXTLNS+1" RTN","PXBD POV",148,0 ) .S @PXTM P@(PXTLNS, 0)=0_U_PXB SAM(PX124, "I")"RTN", "PXBDPOV", 149,0) S P XBCNT=PXTL NS"RTN","P XBDPOV",15 0,0) Q"RTN ","PXBDPOV ",151,0) ; "RTN","PXB GPOV")0^34 ^B12499529 "RTN","PXB GPOV",1,0) PXBGPOV ;I SL/JVS,ESW  - GATHER  POV (DIAGN OSIS) ;8/1 0/04 1:30p m"RTN","PX BGPOV",2,0 ) ;;1.0;PC E PATIENT  CARE ENCOU NTER;**11, 112,149,12 4,168,199, 207**;Aug  12, 1996;B uild 54"RT N","PXBGPO V",3,0) ;" RTN","PXBG POV",4,0)P OV(VISIT)  ;--Gather  the entrie s in the V  POV file" RTN","PXBG POV",5,0)  ;"RTN","PX BGPOV",6,0 ) N DA,DIC ,DIQ,DR,GR OUP,I,IEN, PKG,POV,PO VI,PRIM,PR OBLEM,PROV IDER,PXBC" RTN","PXBG POV",7,0)  N PXBPL,PX BPLA,PXCI, PXDXDATE,Q UANTITY,SN ARR,SOURC" RTN","PXBG POV",8,0)  ;"RTN","PX BGPOV",9,0 ) K ^TMP(" PXBU",$J), POV,PXBKY, PXBSAM,PXB SKY,PXDIGN S,NOPLLIST "RTN","PXB GPOV",10,0 ) K ^UTILI TY("DIQ1", $J)"RTN"," PXBGPOV",1 1,0) S FPR I="",PROBL EM="""RTN" ,"PXBGPOV" ,12,0) I $ D(^AUPNVPO V("AD",VIS IT)) D"RTN ","PXBGPOV ",13,0) .S  IEN=0 F   S IEN=$O(^ AUPNVPOV(" AD",VISIT, IEN)) Q:IE N'>0  D"RT N","PXBGPO V",14,0) . .S ^TMP("P XBU",$J,"P OV",IEN)=" ""RTN","PX BGPOV",15, 0) ;"RTN", "PXBGPOV", 16,0)A ;-- Set array  with DIAGN OSIS codes "RTN","PXB GPOV",17,0 ) ;"RTN"," PXBGPOV",1 8,0) D PL^ PXBGPL(PAT IENT)"RTN" ,"PXBGPOV" ,19,0) I $ D(^TMP("PX BU",$J,"PO V")) D"RTN ","PXBGPOV ",20,0) .S  IEN=0 F   S IEN=$O(^ TMP("PXBU" ,$J,"POV", IEN)) Q:IE N'>0  D"RT N","PXBGPO V",21,0) . .;  djs  P X*1.0*207   RSD SPEC  #2.6.2.4.4 .1  Includ ed Camp Le jeune in f ield list" RTN","PXBG POV",22,0)  ..S DIC=9 000010.07, DR=".01;12 04;.04;.12 ;.17;81202 ;81203;800 01:80009", DA=IEN,DIQ (0)="IE" D  EN^DIQ1"R TN","PXBGP OV",23,0)  ..S PROVID ER=$G(^UTI LITY("DIQ1 ",$J,90000 10.07,DA," 1204","E") )"RTN","PX BGPOV",24, 0) ..S LNA RR=$G(^UTI LITY("DIQ1 ",$J,90000 10.07,DA," .04","E")) "RTN","PXB GPOV",25,0 ) ..S POV= $G(^UTILIT Y("DIQ1",$ J,9000010. 07,DA,".01 ","E"))"RT N","PXBGPO V",26,0) . .S PROBLEM ="" S:$D(^ TMP("PXBKY PL",$J,POV )) PROBLEM ="YES""RTN ","PXBGPOV ",27,0) .. S POVI=$G( ^UTILITY(" DIQ1",$J,9 000010.07, DA,".01"," I"))"RTN", "PXBGPOV", 28,0) ..S  PRIM=$G(^U TILITY("DI Q1",$J,900 0010.07,DA ,".12","E" ))"RTN","P XBGPOV",29 ,0) ..S OR DER=$G(^UT ILITY("DIQ 1",$J,9000 010.07,DA, ".17","E") )"RTN","PX BGPOV",30, 0) ..S PKG =$G(^UTILI TY("DIQ1", $J,9000010 .07,DA,"81 202","I")) "RTN","PXB GPOV",31,0 ) ..I PKG' ]"" S PKG= "NONE""RTN ","PXBGPOV ",32,0) .. S SOURC=$G (^UTILITY( "DIQ1",$J, 9000010.07 ,DA,"81203 ","I"))"RT N","PXBGPO V",33,0) . .I SOURC'] "" S SOURC ="NONE""RT N","PXBGPO V",34,0) . .S PXDXDAT E=$$CSDATE ^PXDXUTL(V ISIT)"RTN" ,"PXBGPOV" ,35,0) ..S  SNARR=$P( $$ICDDATA^ ICDXCODE(" DIAG",POVI ,PXDXDATE, "I"),U,4)" RTN","PXBG POV",36,0)  ..I $L(LN ARR)'>30 S  LNARR=$$D XNARR^PXUT L1(POVI,PX DXDATE)"RT N","PXBGPO V",37,0) . .S FPRI=FP RI_$E(PRIM ,1,3) ;--C reating fl ag for Pri mary promp t"RTN","PX BGPOV",38, 0) ..S GRO UP=POV_"^" _PROVIDER_ "^"_SNARR_ "^"_PRIM_" ^"_PROBLEM _"^"_LNARR _"^"_ORDER "RTN","PXB GPOV",39,0 ) ..;         1         2             3         4           5           6          7"RT N","PXBGPO V",40,0) . .I PRIM["P RI" S PXDI GNS("PRIMA RY")=POV"R TN","PXBGP OV",41,0)  ..S ^TMP(" PXBPOV",$J ,POV,IEN)= GROUP"RTN" ,"PXBGPOV" ,42,0) ..S  ^TMP("PXB GPOVMATCH" ,$J,POVI,I EN)="""RTN ","PXBGPOV ",43,0) .. I $P(GROUP ,"^",5)'[" YES" S NOP LLIST=1"RT N","PXBGPO V",44,0) . .S GROUP=$ G(^UTILITY ("DIQ1",$J ,9000010.0 7,IEN,8000 1,"I"))"RT N","PXBGPO V",45,0) . .;  djs  P X*1.0*207   RSD SPEC  #2.6.2.4.4 .1  Increa se FOR loo p for Camp  Lejeune"R TN","PXBGP OV",46,0)  ..F I=2:1: 9 S GROUP= GROUP_U_$G (^UTILITY( "DIQ1",$J, 9000010.07 ,IEN,80000 +I,"I"))"R TN","PXBGP OV",47,0)  ..S PXCI(I EN)=GROUP, PXBREQ(POV I,"I")=GRO UP"RTN","P XBGPOV",48 ,0) ;"RTN" ,"PXBGPOV" ,49,0)B ;- -Add line  numbers"RT N","PXBGPO V",50,0) ; "RTN","PXB GPOV",51,0 ) I $D(^TM P("PXBPOV" ,$J)) D"RT N","PXBGPO V",52,0) . S PXBC=0,P OV="" F  S  POV=$O(^T MP("PXBPOV ",$J,POV))  Q:POV=""   Q:PXBC>40   D"RTN"," PXBGPOV",5 3,0) ..S I EN=0 F  S  IEN=$O(^TM P("PXBPOV" ,$J,POV,IE N)) Q:IEN= ""  S PXBC =PXBC+1 D" RTN","PXBG POV",54,0)  ...S PXBK Y(POV,PXBC )=$G(^TMP( "PXBPOV",$ J,POV,IEN) ),PXBSAM(P XBC)=$G(^T MP("PXBPOV ",$J,POV,I EN))"RTN", "PXBGPOV", 55,0) ...S  PXBSKY(PX BC,IEN)="" "RTN","PXB GPOV",56,0 ) ...S PXB SAM(PXBC," LNARR")=$P (PXBSAM(PX BC),U,6)"R TN","PXBGP OV",57,0)  ...S PXBSA M(PXBC,"I" )=PXCI(IEN )"RTN","PX BGPOV",58, 0)FINISG ; --finish u p some var iables"RTN ","PXBGPOV ",59,0) ;- -FPRI=0 NO  PRIMARY"R TN","PXBGP OV",60,0)  S:FPRI'["P RI" FPRI=0  S:FPRI["P RI" FPRI=1 "RTN","PXB GPOV",61,0 )EXIT ;--K ILL"RTN"," PXBGPOV",6 2,0) K ^TM P("PXBU",$ J),^TMP("P XBKYPL",$J ),^TMP("PX BSAMPL",$J ),PXBSKYPL "RTN","PXB GPOV",63,0 ) K ^TMP(" PXBPOV",$J ),^UTILITY ("DIQ1",$J )"RTN","PX BGPOV",64, 0) S PXBCN T=+$G(PXBC )"RTN","PX BGPOV",65, 0) Q"RTN", "PXBGPOV", 66,0) ;"RT N","PXBGPO V",67,0)XL ATE(VST,DX ) ;Transla te DX into  POV from  VST"RTN"," PXBGPOV",6 8,0) Q:'$G (VST)!'$G( DX) ""  Q: '$D(^AUPNV POV("AD",V ST)) """RT N","PXBGPO V",69,0) S  DX=+$$ICD DATA^ICDXC ODE("DIAG" ,DX,$$CSDA TE^PXDXUTL (VST),"I")  Q:DX<0 "" "RTN","PXB GPOV",70,0 ) N IEN,AN S,VAL S (I EN,ANS,VAL )="""RTN", "PXBGPOV", 71,0) F  Q :ANS  D"RT N","PXBGPO V",72,0) . S IEN=$O(^ AUPNVPOV(" AD",VST,IE N)) I 'IEN  S ANS=1 Q "RTN","PXB GPOV",73,0 ) .S VAL=$ G(^AUPNVPO V(IEN,0)), ANS=($P(VA L,U)=DX)"R TN","PXBGP OV",74,0)  S ANS=IEN_ U_DX_U_$P( VAL,U,12)  S:IEN ANS= ANS_U_$G(^ AUPNVPOV(I EN,800))"R TN","PXBGP OV",75,0)  Q ANS"RTN" ,"PXBGPOV" ,76,0) ;"R TN","PXBIB B")0^8^B18 177835"RTN ","PXBIBB" ,1,0)PXBIB B ;ALB/DWS /BDB - SEN D CHARGE O R CREDIT T RANSACTION S TO IBB ; 8/10/05 1: 29pm"RTN", "PXBIBB",2 ,0) ;;1.0; PCE PATIEN T CARE ENC OUNTER;**1 64,207**;A ug 12, 199 6;Build 54 "RTN","PXB IBB",3,0)  N VSTB,PKB ,VSTA,PKA, PRVB,PRVA, SC,IBBAPLR ,IBBDFN"RT N","PXBIBB ",4,0) N I BBARFN,IBB UCID,CD,CD 12,CDA,CDB ,CDI,DX,IO ,MOD"RTN", "PXBIBB",5 ,0) N IBBC TYPE,IBBOR IEN,ND,TYP E,VDT,PPRV ,SPRV,APRV ,OPRV,ORY" RTN","PXBI BB",6,0) S  VSTA=$G(^ TMP("PXKCO ",$J,PXKVV ST,"VST",P XKVVST,0," AFTER"))"R TN","PXBIB B",7,0) S  PKA=$G(^TM P("PXKCO", $J,PXKVVST ,"VST",PXK VVST,812," AFTER"))"R TN","PXBIB B",8,0) S  IO=$P($G(^ TMP("PXKCO ",$J,PXKVV ST,"VST",P XKVVST,150 ,"AFTER")) ,U,2)"RTN" ,"PXBIBB", 9,0) S VST B=$G(^TMP( "PXKCO",$J ,PXKVVST," VST",PXKVV ST,0,"BEFO RE"))"RTN" ,"PXBIBB", 10,0) S PK B=$G(^TMP( "PXKCO",$J ,PXKVVST," VST",PXKVV ST,812,"BE FORE"))"RT N","PXBIBB ",11,0) S: IO="" IO=$ P($G(^TMP( "PXKCO",$J ,PXKVVST," VST",PXKVV ST,150,"BE FORE")),U, 2)"RTN","P XBIBB",12, 0) Q:$P(VS TB,U,7)="E "  Q:$P(VS TA,U,7)="E ""RTN","PX BIBB",13,0 ) Q:$P(PKB ,U,2)=$$PK G2IEN^VSIT ("RMPR")   Q:$P(PKA,U ,2)=$$PKG2 IEN^VSIT(" RMPR")"RTN ","PXBIBB" ,14,0) S S C=$O(^SCE( "AVSIT",PX KVVST,0))" RTN","PXBI BB",15,0)  S:'SC SC=$ O(^TMP("PX KCO",$J,PX KVVST,"OE" ,0)) D:'SC   Q:'SC"RT N","PXBIBB ",16,0) .Q :'IO"RTN", "PXBIBB",1 7,0) .S CD I=0 F  S C DI=$O(^TMP ("PXKCO",$ J,PXKVVST, "CPT",CDI) ) Q:CDI=""   D"RTN"," PXBIBB",18 ,0) ..S CD B=$G(^TMP( "PXKCO",$J ,PXKVVST," CPT",CDI,0 ,"BEFORE") )"RTN","PX BIBB",19,0 ) ..I $P(C DB,U)'=""  S CD=CDB,C D12=$G(^TM P("PXKCO", $J,PXKVVST ,"CPT",CDI ,12,"BEFOR E")) D CHG ("BEFORE") "RTN","PXB IBB",20,0)  ..S CDA=$ G(^TMP("PX KCO",$J,PX KVVST,"CPT ",CDI,0,"A FTER"))"RT N","PXBIBB ",21,0) .. I $P(CDA,U )'="" S CD =CDA,CD12= $G(^TMP("P XKCO",$J,P XKVVST,"CP T",CDI,12, "AFTER"))  D CHG("AFT ER")"RTN", "PXBIBB",2 2,0) S BST ATUS=$P($G (^TMP("PXK CO",$J,PXK VVST,"OE", SC,0,"BEFO RE")),U,7) "RTN","PXB IBB",23,0)  I '$P($G( ^SCE(SC,0) ),U,7) Q:' BSTATUS  D   Q"RTN"," PXBIBB",24 ,0) .S CDI =0 F  S CD I=$O(^TMP( "PXKCO",$J ,PXKVVST," CPT",CDI))  Q:CDI=""   D"RTN","P XBIBB",25, 0) ..S CD= $G(^TMP("P XKCO",$J,P XKVVST,"CP T",CDI,0," BEFORE"))" RTN","PXBI BB",26,0)  ..S CD12=$ G(^TMP("PX KCO",$J,PX KVVST,"CPT ",CDI,12," BEFORE"))" RTN","PXBI BB",27,0)  ..D CHG("B EFORE")"RT N","PXBIBB ",28,0) S  CDI=0 F  S  CDI=$O(^T MP("PXKCO" ,$J,PXKVVS T,"CPT",CD I)) Q:CDI= ""  D"RTN" ,"PXBIBB", 29,0) .S:B STATUS CDB =$G(^TMP(" PXKCO",$J, PXKVVST,"C PT",CDI,0, "BEFORE")) "RTN","PXB IBB",30,0)  .S CDA=$G (^TMP("PXK CO",$J,PXK VVST,"CPT" ,CDI,0,"AF TER"))"RTN ","PXBIBB" ,31,0) .I  BSTATUS,$P (CDA,U)=""  D  D CHG( "BEFORE")  Q"RTN","PX BIBB",32,0 ) ..S CD=C DB,CD12=$G (^TMP("PXK CO",$J,PXK VVST,"CPT" ,CDI,12,"B EFORE"))"R TN","PXBIB B",33,0) . S CD=CDA,C D12=$G(^TM P("PXKCO", $J,PXKVVST ,"CPT",CDI ,12,"AFTER "))"RTN"," PXBIBB",34 ,0) .D CHG ("AFTER")" RTN","PXBI BB",35,0)  Q"RTN","PX BIBB",36,0 )CHG(TYPE)  ;PROCESS  DEBITS OR  CREDITS, B EFORE = CR EDIT, AFTE R = DEBIT" RTN","PXBI BB",37,0)  N IBBFT1,I BBPR1,IBBD G1,IBBZCL, DXS,FDX,I" RTN","PXBI BB",38,0)  D LD($S(VS TA:VSTA,1: VSTB))"RTN ","PXBIBB" ,39,0) S I BBUCID=$P( CD,U,20),I BBORIEN=$P (CD,U,17), IBBFT1(2)= "PX"_PXKVV ST,IBBFT1( 20)=$P(CD1 2,U,4),IBB FT1(21)=$P (CD12,U,2)  ;PRFM,ORD R - CPT EN C,ORD"RTN" ,"PXBIBB", 40,0) I 'I BBUCID S I BBUCID=$$G ETCHGID^IB BAPI(),DA= CDI,DR=".2 ///"_IBBUC ID D"RTN", "PXBIBB",4 1,0) .S DI E="^AUPNVC PT(" D ^DI E"RTN","PX BIBB",42,0 ) S I="" F   S I=$O(^ TMP("PXKCO ",$J,PXKVV ST,"PRV",I )) Q:I=""   D"RTN","P XBIBB",43, 0) .S PRV= $G(^TMP("P XKCO",$J,P XKVVST,"PR V",I,0,TYP E))"RTN"," PXBIBB",44 ,0) .I $P( PRV,U,4)=" P" S PPRV= +PRV"RTN", "PXBIBB",4 5,0) .I $P (PRV,U,4)= "S" S SPRV =+PRV"RTN" ,"PXBIBB", 46,0) .I $ P(PRV,U,5) ="A" S APR V=+PRV"RTN ","PXBIBB" ,47,0) .I  $P(PRV,U,5 )="O" S OP RV=+PRV"RT N","PXBIBB ",48,0) I  IBBFT1(20) ="" S IBBF T1(20)=$G( PPRV) ;PRF M - NULL,  THEN PRV P RIMARY"RTN ","PXBIBB" ,49,0) S I BBCTYPE=$S (TYPE="BEF ORE":"CD", 1:"CG"),IB BFT1(10)=$ P(CD,U,16) "RTN","PXB IBB",50,0)  S (IBBFT1 (13),I)=$S ($P(CD,U,1 9)]"":$P(C D,U,19),1: 999),IBBFT 1(4)=$S(CD 12:+CD12,1 :VDT)"RTN" ,"PXBIBB", 51,0) S IB BPR1(3)=+C D,IBBPR1(5 )=IBBFT1(4 )"RTN","PX BIBB",52,0 ) I "180^4 01^402^403 ^404^406^4 07^409^410 ^411^412^4 13^415^457 "[I D"RTN" ,"PXBIBB", 53,0) .S I BBPR1(11,1 )=$G(OPRV)  I IBBPR1( 11,1)="" S  IBBPR1(11 ,1)=IBBFT1 (20)"RTN", "PXBIBB",5 4,0) .S IB BPR1(11,2) =$G(APRV)" RTN","PXBI BB",55,0)  N IBBARFNZ  I $E($T(O RACTREF^OR WPFSS),9)= "(",I=108, IBBORIEN D  ORACTREF^ ORWPFSS(.I BBARFNZ,.I BBORIEN) I  IBBARFNZ] "" S IBBAR FN=IBBARFN Z"RTN","PX BIBB",56,0 ) S MOD="" ,I=0"RTN", "PXBIBB",5 7,0) F  S  I=$O(^TMP( "PXKCO",$J ,PXKVVST," CPT",CDI,1 ,TYPE,I))  Q:I=""  S  MOD=$S(MOD ="":I,1:MO D_";"_I)"R TN","PXBIB B",58,0) S  I=0 F  S  I=$O(^TMP( "PXKCO",$J ,PXKVVST," POV",I)) Q :I=""  D"R TN","PXBIB B",59,0) . S DXS=$G(^ (I,0,TYPE) )"RTN","PX BIBB",60,0 ) .S DXS(+ DXS)=$G(^T MP("PXKCO" ,$J,PXKVVS T,"POV",I, 800,TYPE)) "RTN","PXB IBB",61,0)  S IBBPR1( 16)=MOD"RT N","PXBIBB ",62,0) ;   djs  PX*1 .0*207  RS D SPEC #2. 6.2  Incre ase FOR lo op for Cam p Lejeune" RTN","PXBI BB",63,0)  F I=1:1:9  S SC(I)=""  ;SHAD & C AMP LEJEUN E"RTN","PX BIBB",64,0 ) S FDX=1  F I=5,9:1: 15 S DX=$P (CD,U,I) I  DX S J=$S (I=5:1,1:I -7) D  S F DX=0"RTN", "PXBIBB",6 5,0) .S IB BDG1(J,3)= DX,IBBDG1( J,6)="F",D XS=$G(DXS( DX))"RTN", "PXBIBB",6 6,0) .;  d js  PX*1.0 *207  RSD  SPEC #2.6. 2  Increas e FOR loop  for Camp  Lejeune"RT N","PXBIBB ",67,0) .F  J=1:1:9 I  'SC(J) D   ;SHAD & C AMP LEJEUN E"RTN","PX BIBB",68,0 ) ..I $P($ G(DXS(DX)) ,U,J) S SC (J)=1 Q"RT N","PXBIBB ",69,0) .. I $P($G(DX S(DX)),U,J )="" S SC( J)="" Q"RT N","PXBIBB ",70,0) .. I $P($G(DX S(DX)),U,J )=0,FDX=1  S SC(J)=0" RTN","PXBI BB",71,0)  S SC=$G(^T MP("PXKCO" ,$J,PXKVVS T,"VST",PX KVVST,800, TYPE))"RTN ","PXBIBB" ,72,0) ;   djs  PX*1. 0*207  RSD  SPEC #2.6 .2  Increa se FOR loo ps for Cam p Lejeune" RTN","PXBI BB",73,0)  F I=1:1:9  I SC(I)=""  S SC(I)=$ P(SC,U,I)  ;SHAD & CA MP LEJEUNE "RTN","PXB IBB",74,0)  F I=1:1:9  S J=$S(I= 1:3,I=2:1, I=3:2,1:I) ,IBBZCL(J, 2)=J,IBBZC L(J,3)=SC( I) ;SHAD &  CAMP LEJE UNE"RTN"," PXBIBB",75 ,0) I IBBZ CL(3,3) F  I=1,2,4,9  S IBBZCL(I ,3)=""  ;  CAMP LEJEU NE"RTN","P XBIBB",76, 0) W $$CHA RGE^IBBAPI (IBBDFN,IB BARFN,IBBC TYPE,IBBUC ID,.IBBFT1 ,.IBBPR1,. IBBDG1,.IB BZCL,.IBBR XE,IBBORIE N,.IBBPROS )"RTN","PX BIBB",77,0 ) Q"RTN"," PXBIBB",78 ,0)LD(ND)  S IBBDFN=$ P(ND,U,5), IBBARFN=$P (ND,U,26), VDT=+ND"RT N","PXBIBB ",79,0) Q" RTN","PXBP L")0^9^B26 668858"RTN ","PXBPL", 1,0)PXBPL  ;ISL/JVS -  ADD DIAGN OSIS TO PR OBLEM LIST  ;17 Jul 2 013  11:21  AM"RTN"," PXBPL",2,0 ) ;;1.0;PC E PATIENT  CARE ENCOU NTER;**11, 94,115,130 ,168,199,2 07**;Aug 1 2, 1996;Bu ild 54"RTN ","PXBPL", 3,0) ;"RTN ","PXBPL", 4,0) ;"RTN ","PXBPL", 5,0) ;"RTN ","PXBPL", 6,0) W !," THIS IS NO T AN ENTRY  POINT" Q" RTN","PXBP L",7,0)SET  ;--SETUP  AND NEW VA RIABLES"RT N","PXBPL" ,8,0) N OK ,PXBPL,PXP RVLIN,FLAG ,DATA,ICDC ODE"RTN"," PXBPL",9,0 ) S PXPRVL IN=18 D WI N17^PXBCC( PXBCNT)"RT N","PXBPL" ,10,0) I ' $G(NOPLLIS T) Q"RTN", "PXBPL",11 ,0)PRMPT ; --Ask if y ou want to  put entri es in PL"R TN","PXBPL ",12,0) D  LOC^PXBCC( 17,0) S DI R(0)="Y,A, O""RTN","P XBPL",13,0 ) S DIR("B ")="NO""RT N","PXBPL" ,14,0) I P XBCNT'>1 S  DIR("A")= "Would you  like to a dd this Di agnosis to  the Probl em List? " "RTN","PXB PL",15,0)  I PXBCNT>1  S DIR("A" )="Would y ou like to  add any D iagnoses t o the Prob lem List?  ""RTN","PX BPL",16,0)  D ^DIR K  DIR"RTN"," PXBPL",17, 0) I Y=0!( Y="^")!(Y= "") Q"RTN" ,"PXBPL",1 8,0)SELECT  ;--Select  entries f or PL"RTN" ,"PXBPL",1 9,0) W !"R TN","PXBPL ",20,0) I  PXBCNT'>1  S OK=1"RTN ","PXBPL", 21,0) I PX BCNT>1 S P XPRVLIN=PX PRVLIN+2 W  !,"Select  1 or seve ral Diagno ses (e.g.  1,3,4,7,3- 6,2-5): "  R OK:DTIME "RTN","PXB PL",22,0)  I OK?1.N1" E".NAP S O K=" "_OK"R TN","PXBPL ",23,0) I  OK?24.N S  OK=$E(OK,1 ,24)"RTN", "PXBPL",24 ,0) ;"RTN" ,"PXBPL",2 5,0) ;"RTN ","PXBPL", 26,0) I OK ["-" D"RTN ","PXBPL", 27,0) .N P IECE,PXBI, PXBJ,PXBK" RTN","PXBP L",28,0) . S PIECE=""  F PXBI=1: 1:$L(OK,", ") S PIECE =$P(OK,"," ,PXBI) I P IECE["-" D "RTN","PXB PL",29,0)  ..S PXBJ=0  F PXBJ=$P (PIECE,"-" ,1):1:$P(P IECE,"-",2 ) S PXBK=" ,"_PXBJ,OK =OK_PXBK"R TN","PXBPL ",30,0) ;" RTN","PXBP L",31,0) ; "RTN","PXB PL",32,0)  ;"RTN","PX BPL",33,0)  S PXBLEN= 0"RTN","PX BPL",34,0)  I OK["?"  W !,"Enter  the ITEM  numbers of  the entri es you wis h to add t o the PROB LEM LIST."  S PXPRVLI N=PXPRVLIN +1 G SELEC T"RTN","PX BPL",35,0)  ;----SPAC E BAR----- ----"RTN", "PXBPL",36 ,0) I OK'= " ",OK'["^ ",OK'="" S  ^DISV(DUZ ,"PXBPL-2" )=OK"RTN", "PXBPL",37 ,0) I OK="  ",$D(^DIS V(DUZ,"PXB PL-2")) S  OK=^DISV(D UZ,"PXBPL- 2") W OK"R TN","PXBPL ",38,0) ;- ---------- ---------- --"RTN","P XBPL",39,0 ) S PXBLEN =$L(OK,"," ) F PXI=1: 1:PXBLEN S  PXBPIECE= $P(OK,",", PXI) D"RTN ","PXBPL", 40,0) .Q:P XBPIECE="" "RTN","PXB PL",41,0)  .I $D(PXBS AM(PXBPIEC E)) D"RTN" ,"PXBPL",4 2,0) ..I P XBCNT>10 D  DPOV4^PXB DPOV(PXBSA M(PXBPIECE ,"LINE"))" RTN","PXBP L",43,0) . .S FLAG=1" RTN","PXBP L",44,0) . .D REVPOV^ PXBPPOV(PX BPIECE)"RT N","PXBPL" ,45,0) I ' $G(FLAG) S  DIR(0)="Y ^AO",DIR(" B")="NO",D IR("A")="I NVALID ent ry. Would  you like t o try agai n" D ^DIR  K DIR I Y= 1 K Y S PX PRVLIN=PXP RVLIN+1 G  SELECT"RTN ","PXBPL", 46,0)PRV ; --Ask for  provider"R TN","PXBPL ",47,0) I  '$G(FLAG)  Q"RTN","PX BPL",48,0)  S FROM="P L" K PXBCN T D PRV^PX BGPRV(PXBV ST,,,,.PXB CNT)"RTN", "PXBPL",49 ,0) N PXBL ANKS S $P( PXBLANKS,"  ",65)=""" RTN","PXBP L",50,0) D  LOC^PXBCC (1,10) W P XBLANKS D  LOC^PXBCC( PXPRVLIN,0 )"RTN","PX BPL",51,0) R K ERROR  S FROM="PL " D PRV^PX BPPRV G:$G (ERROR) R  W IOEDEOP" RTN","PXBP L",52,0) I  DATA["^P"  D LOC^PXB CC(3,0),EN 0^PXBDPRV, LOC^PXBCC( 15,0) G PR V"RTN","PX BPL",53,0)  D POV^PXB GPOV(PXBVS T)"RTN","P XBPL",54,0 )LOOP ;--L oop throug h diagnose s"RTN","PX BPL",55,0)  S PXBLEN= $L(OK,",")  F PXI=1:1 :PXBLEN S  PXBPIECE=$ P(OK,",",P XI) D"RTN" ,"PXBPL",5 6,0) .I PX BPIECE=""  Q"RTN","PX BPL",57,0)  .I $D(PXB SAM(PXBPIE CE)) D"RTN ","PXBPL", 58,0) ..S  PXBPL("PAT IENT")=PAT IENT"RTN", "PXBPL",59 ,0) ..S PX BPL("NARRA TIVE")=$P( $G(PXBSAM( PXBPIECE)) ,"^",3)"RT N","PXBPL" ,60,0) ..S  PXBPL("PR OVIDER")=$ P(REQI,"^" ,1)"RTN"," PXBPL",61, 0) ..S PXB PL("DIAGNO SIS")=+^AU PNVPOV($O( PXBSKY(PXB PIECE,0)), 0)"RTN","P XBPL",62,0 ) ..S PXBP L("LOCATIO N")=$P(^AU PNVSIT(PXB VST,0),"^" ,22)"RTN", "PXBPL",63 ,0) ..;PRH  - PX*1*11 5 - Set up  Service C onditions" RTN","PXBP L",64,0) . .N PXSCSTR ,PXII,PXTY P"RTN","PX BPL",65,0)  ..;  djs   PX*1.0*20 7  RSD SPE C #2.6.2   Add Camp L ejeune to  environmen tal indica tors strin g and incr ease FOR l oop"RTN"," PXBPL",66, 0) ..S PXS CSTR="SC^A O^IR^EC^MS T^HNC^CV^S HAD^CLV""R TN","PXBPL ",67,0) .. F PXII=1:1 :9 D"RTN", "PXBPL",68 ,0) ...S P XTYP=$P(PX SCSTR,"^", PXII)"RTN" ,"PXBPL",6 9,0) ...S  PXBPL(PXTY P)=$P($G(^ AUPNVSIT(P XBVST,800) ),"^",PXII )"RTN","PX BPL",70,0)  ..S ICDCO DE="",ICDC ODE=$P($G( PXBSAM(PXB PIECE)),"^ ",1)"RTN", "PXBPL",71 ,0) ..I IC DCODE'=""  D  ; Get L exicon ent ry for ICD  Code"RTN" ,"PXBPL",7 2,0) ...S  PXVDATE=$$ CSDATE^PXD XUTL(PXBVS T)  ; $P(+ ^AUPNVSIT( PXBVST,0), ".",1)"RTN ","PXBPL", 73,0) ...K ILL LEXS D  EN^LEXCOD E(ICDCODE, PXVDATE)"R TN","PXBPL ",74,0) .. .S PXACSRE C=$$ACTDT^ PXDXUTL(PX VDATE),PXA CSID=$P(PX ACSREC,U,1 )"RTN","PX BPL",75,0)  ...I $G(L EXS(PXACSI D,0))>0 S  PXBPL("LEX ICON")=$P( $G(LEXS(PX ACSID,1)), "^",1)"RTN ","PXBPL", 76,0) ..S  PXBPL("DX_ DATE_OF_IN TEREST")=$ $CSDATE^PX DXUTL(PXBV ST)"RTN"," PXBPL",77, 0) ..D CRE ATE^GMPLUT L(.PXBPL,. PXBRES)"RT N","PXBPL" ,78,0) ..D  PR"RTN"," PXBPL",79, 0) K NOPLL IST,PXVDAT E,PXACSREC ,PXACSID"R TN","PXBPL ",80,0) Q" RTN","PXBP L",81,0)SE ND ;--Entr y point to  send data  to proble m list"RTN ","PXBPL", 82,0) N PX BPL,OK,ICD CODE,PXVDA TE,PXACSRE C,PXACSID" RTN","PXBP L",83,0) I  '$D(IORVO N) D TERM^ PXBCC"RTN" ,"PXBPL",8 4,0) S PXB PL("PATIEN T")=PATIEN T"RTN","PX BPL",85,0)  S PXBPL(" NARRATIVE" )=PXBSAM($ O(PXBKY($P ($P(REQE," ^",5)," ", 1),0)),"LN ARR")"RTN" ,"PXBPL",8 6,0) S PXB PL("PROVID ER")=$P(RE QI,"^",1)" RTN","PXBP L",87,0) S  PXBPL("DI AGNOSIS")= $P(REQI,"^ ",5)"RTN", "PXBPL",88 ,0) S PXBP L("LOCATIO N")=$P(^AU PNVSIT(PXB VST,0),"^" ,22)"RTN", "PXBPL",89 ,0) ;PRH -  PX*1*115  - Set up S ervice Con ditions"RT N","PXBPL" ,90,0) N P XSCSTR,PXI I,PXTYP"RT N","PXBPL" ,91,0) ;   djs  PX*1. 0*207  RSD  SPEC #2.6 .2  Add Ca mp Lejeune  to enviro nmental in dicators s tring and  increase F OR loop"RT N","PXBPL" ,92,0) S P XSCSTR="SC ^AO^IR^EC^ MST^HNC^CV ^SHAD^CLV" "RTN","PXB PL",93,0)  F PXII=1:1 :9 D"RTN", "PXBPL",94 ,0) . S PX TYP=$P(PXS CSTR,"^",P XII)"RTN", "PXBPL",95 ,0) . S PX BPL(PXTYP) =$P($G(^AU PNVSIT(PXB VST,800)), "^",PXII)" RTN","PXBP L",96,0) S  ICDCODE=" ",ICDCODE= $P($G(PXBS AM($O(PXBK Y($P($P(RE QE,"^",5), " ",1),0)) )),"^",1)" RTN","PXBP L",97,0) I  ICDCODE'= "" D  ; Ge t Lexicon  entry for  ICD Code"R TN","PXBPL ",98,0) .S  PXVDATE=$ $CSDATE^PX DXUTL(PXBV ST)  ; $P( +^AUPNVSIT (PXBVST,0) ,".",1)"RT N","PXBPL" ,99,0) .KI LL LEXS D  EN^LEXCODE (ICDCODE,P XVDATE)"RT N","PXBPL" ,100,0) .S  PXACSREC= $$ACTDT^PX DXUTL(PXVD ATE),PXACS ID=$P(PXAC SREC,U,1)" RTN","PXBP L",101,0)  .I $G(LEXS (PXACSID,0 ))>0 S PXB PL("LEXICO N")=$P($G( LEXS(PXACS ID,1)),"^" ,1)"RTN"," PXBPL",102 ,0) S PXBP L("DX_DATE _OF_INTERE ST")=$$CSD ATE^PXDXUT L(PXBVST)" RTN","PXBP L",103,0)  D CREATE^G MPLUTL(.PX BPL,.PXBRE S)"RTN","P XBPL",104, 0)PR ;"RTN ","PXBPL", 105,0) I P XBRES<0 D   Q  ;'Q'ui t added fo r PX*1*115 "RTN","PXB PL",106,0)  .W !,IORV ON,"--WARN ING-Proble m NOT Crea ted becaus e: ",PXBRE S(0),IORVO FF"RTN","P XBPL",107, 0) .D HELP 1^PXBUTL1( "CON") R O K:DTIME"RT N","PXBPL" ,108,0) ;" RTN","PXBP L",109,0)  ;PX*1*115  - Add Prob lem File P ointer to  V POV file "RTN","PXB PL",110,0)  I PXBRES> 0 D"RTN"," PXBPL",111 ,0) . N DA ,DIE,DR,PX BPLARR,PXB PLERR,PXBP LPOV"RTN", "PXBPL",11 2,0) . S D A=$O(PXBSK Y(PXBPIECE ,0))"RTN", "PXBPL",11 3,0) . S P XBPLPOV=90 00010.07"R TN","PXBPL ",114,0) .  K PXBPLAR R,PXBPLERR "RTN","PXB PL",115,0)  . D GETS^ DIQ(PXBPLP OV,(DA_"," ),.16,"I", "PXBPLARR" ,"PXBPLERR ")"RTN","P XBPL",116, 0) . Q:$D( PXBPLERR)" RTN","PXBP L",117,0)  . I $L($G( PXBPLARR(P XBPLPOV,(D A_","),.16 ,"I"))) Q" RTN","PXBP L",118,0)  . ;"RTN"," PXBPL",119 ,0) . S DI E="^AUPNVP OV(",DR=". 16////"_PX BRES"RTN", "PXBPL",12 0,0) . D ^ DIE"RTN"," PXBPL",121 ,0) ;"RTN" ,"PXBPL",1 22,0) Q"RT N","PXCEAP PM")0^16^B 7103705"RT N","PXCEAP PM",1,0)PX CEAPPM ;IS L/dee,ISA/ KWP - Used  to add a  new visit  from the a ppointment  display a nd display  a visit ; 04/28/99"R TN","PXCEA PPM",2,0)  ;;1.0;PCE  PATIENT CA RE ENCOUNT ER;**22,74 ,111,130,1 24,168,207 **;Aug 12,  1996;Buil d 54"RTN", "PXCEAPPM" ,3,0) ;+Th e classifi cations ar e displaye d with thi s routine  when addin g"RTN","PX CEAPPM",4, 0) ;+an en counter fr om the app ointment l ist"RTN"," PXCEAPPM", 5,0) Q"RTN ","PXCEAPP M",6,0) ;" RTN","PXCE APPM",7,0)  ;Line wit h the line  label "FO RMAT""RTN" ,"PXCEAPPM ",8,0) ;;L ong name~F ile Number ~Node Subs cripts~All ow Duplica te entries  (not used  on visit) ~File glob al name"RT N","PXCEAP PM",9,0) ;      1          2              3                     4                                             5"RTN","PX CEAPPM",10 ,0) ;"RTN" ,"PXCEAPPM ",11,0) ;F ollowing l ines:"RTN" ,"PXCEAPPM ",12,0) ;; Node~Piece ~,Field Nu mber~Edit  Label~Disp lay Label~ Display Ro utine~Edit  Routine~H elp Text f or DIR("?" )~Set of P XCEKEYS th at can Edi t~D if Det ail Displa y Only~"RT N","PXCEAP PM",13,0)  ;  1  ~  2   ~      3       ~      4    ~         5     ~         6      ~      7       ~       8                ~           9                    ~        10"RTN"," PXCEAPPM", 14,0) ;The  Display &  Edit rout ines are f or special  cases."RT N","PXCEAP PM",15,0)  ;"RTN","PX CEAPPM",16 ,0)FORMAT  ;;Encounte r~9000010~ 0,21,150,8 00,811,812 ~~^AUPNVSI T"RTN","PX CEAPPM",17 ,0) ;;0~1~ .01~Encoun ter Date a nd Time:   ~Encounter  Date and  Time:  ~~E VISITDT^PX CEVSIT(1)~ ~~B"RTN"," PXCEAPPM", 18,0) ;;0~ 18~.18~Che ck Out ~Ch eck Out Da te and Tim e:  ~~ECOD T^PXCEVSIT ~~~D"RTN", "PXCEAPPM" ,19,0) ;;8 00~1~80001 ~Service C onnected:   ~Service  Connected:   ~~GET800 ^PXCEE800~ ~~D"RTN"," PXCEAPPM", 20,0) ;;80 0~7~80007~ Combat Vet eran:  ~Co mbat Veter an:  ~~SKI P^PXCEVSIT ~~~D"RTN", "PXCEAPPM" ,21,0) ;;8 00~2~80002 ~Agent Ora nge Exposu re:  ~Agen t Orange E xposure:   ~~SKIP^PXC EVSIT~~~D" RTN","PXCE APPM",22,0 ) ;;800~3~ 80003~Ioni zing Radia tion Expos ure:  ~Ion izing Radi ation Expo sure:  ~~S KIP^PXCEVS IT~~~D"RTN ","PXCEAPP M",23,0) ; ;800~4~800 04~SW Asia  Condition s:  ~SW As ia Conditi ons:  ~~SK IP^PXCEVSI T~~~D"RTN" ,"PXCEAPPM ",24,0) ;; 800~8~8000 8~Project  112/SHAD:   ~Project  112/SHAD:   ~~SKIP^PX CEVSIT~~~D "RTN","PXC EAPPM",25, 0) ;;800~5 ~80005~Mil itary Sexu al Trauma:   ~Militar y Sexual T rauma:  ~~ SKIP^PXCEV SIT~~~D"RT N","PXCEAP PM",26,0)  ;;800~6~80 006~Head a nd/or Neck  Cancer:   ~Head and/ or Neck Ca ncer:  ~~S KIP^PXCEVS IT~~~D"RTN ","PXCEAPP M",27,0) ; ;800~9~800 09~Camp Le jeune Expo sure:  ~Ca mp Lejeune  Exposure:   ~~SKIP^P XCEVSIT~~~ D"RTN","PX CEAPPM",28 ,0) ;  djs   PX*1.0*2 07  RSD SP EC #2.6.2. 4.2.1  Add ed Camp Le jeune as a  new item  when addin g new visi t"RTN","PX CEAPPM",29 ,0) ;"RTN" ,"PXCEAPPM ",30,0) ;" RTN","PXCE APPM",31,0 ) ;******* ********** ********** *****"RTN" ,"PXCEAPPM ",32,0) ;S pecial cas es for dis play of vi sit are in  PXCEVSIT. "RTN","PXC EAPPM",33, 0) ;"RTN", "PXCEAPPM" ,34,0) ;** ********** ********** ********** "RTN","PXC EAPPM",35, 0) ;Specia l cases fo r edit of  visit are  in PXCEVSI T."RTN","P XCEAPPM",3 6,0) ;"RTN ","PXCEAPP M",37,0) ; ********** ********** ********** **"RTN","P XCEAPPM",3 8,0) ;Disp lay text f or the .01  field whi ch is a Da te and Tim e."RTN","P XCEAPPM",3 9,0) ;(Mus t have is  called by  ASK^PXCEVF I2 and DEL ^PXCEVFI2. )"RTN","PX CEAPPM",40 ,0)DISPLY0 1(PXCEVSIT ) ;"RTN"," PXCEAPPM", 41,0) Q $$ DISPLY01^P XCESIT(PXC EVSIT)"RTN ","PXCEAPP M",42,0) ; "RTN","PXC EC800")0^3 3^B3740890 "RTN","PXC EC800",1,0 )PXCEC800  ;ISL/dee,I SA/KWP - U sed in edi ting the 8 00 node, S ervice Con nected con ditions ;1 2/22/04 1: 38pm"RTN", "PXCEC800" ,2,0) ;;1. 0;PCE PATI ENT CARE E NCOUNTER;* *124,174,1 68,207**;A ug 12, 199 6;Build 54 "RTN","PXC EC800",3,0 ) ;; ;"RTN ","PXCEC80 0",4,0) Q" RTN","PXCE C800",5,0)  ;"RTN","P XCEC800",6 ,0)GET800  ;Used by t he Service  Connected  Condition s"RTN","PX CEC800",7, 0) N PXCEI NDX,PXOUT" RTN","PXCE C800",8,0)  N PXBDATA ,PXLOC,PXA PTDT,PXDFN "RTN","PXC EC800",9,0 ) I $O(^SC E("AVSIT", PXCEVIEN,0 )) D CLASS ^PXBAPI21( "","",""," ",PXCEVIEN )"RTN","PX CEC800",10 ,0) I '$O( ^SCE("AVSI T",PXCEVIE N,0)) D"RT N","PXCEC8 00",11,0)  . S PXAPTD T=+^AUPNVS IT(PXCEVIE N,0)"RTN", "PXCEC800" ,12,0) . S  PXDFN=$P( ^AUPNVSIT( PXCEVIEN,0 ),"^",5)"R TN","PXCEC 800",13,0)  . S PXLOC =$P(^AUPNV SIT(PXCEVI EN,0),"^", 22)"RTN"," PXCEC800", 14,0) . D  CLASS^PXBA PI21("",PX DFN,PXAPTD T,PXLOC,"" )"RTN","PX CEC800",15 ,0) ;  djs   PX*1.0*2 07  RSD SP EC #2.6.2. 4.4.1  Inc reased FOR  loop for  Camp Lejeu ne"RTN","P XCEC800",1 6,0) F PXC EINDX=1:1: 9 I $G(PXB DATA("ERR" ,PXCEINDX) )=4 S PXOU T=PXBDATA( "ERR",PXCE INDX)"RTN" ,"PXCEC800 ",17,0) I  $D(PXOUT)  S PXCEEND= 1 Q  ;for  visit and  required f ields"RTN" ,"PXCEC800 ",18,0) S  $P(PXCEAFT R(800),"^" ,1)=$P($G( PXBDATA(3) ),"^",2)"R TN","PXCEC 800",19,0)  S $P(PXCE AFTR(800), "^",2)=$P( $G(PXBDATA (1)),"^",2 ) S:$P(PXC EAFTR(800) ,"^",2)=""  $P(PXCEAF TR(800),"^ ",2)="@""R TN","PXCEC 800",20,0)  S $P(PXCE AFTR(800), "^",3)=$P( $G(PXBDATA (2)),"^",2 ) S:$P(PXC EAFTR(800) ,"^",3)=""  $P(PXCEAF TR(800),"^ ",3)="@""R TN","PXCEC 800",21,0)  S $P(PXCE AFTR(800), "^",4)=$P( $G(PXBDATA (4)),"^",2 ) S:$P(PXC EAFTR(800) ,"^",4)=""  $P(PXCEAF TR(800),"^ ",4)="@""R TN","PXCEC 800",22,0)  S $P(PXCE AFTR(800), "^",5)=$P( $G(PXBDATA (5)),"^",2 )"RTN","PX CEC800",23 ,0) S $P(P XCEAFTR(80 0),"^",6)= $P($G(PXBD ATA(6)),"^ ",2)"RTN", "PXCEC800" ,24,0) S $ P(PXCEAFTR (800),"^", 7)=$P($G(P XBDATA(7)) ,"^",2)"RT N","PXCEC8 00",25,0)  S $P(PXCEA FTR(800)," ^",8)=$P($ G(PXBDATA( 8)),"^",2) "RTN","PXC EC800",26, 0) ;  djs   PX*1.0*20 7  RSD SPE C #2.6.2.4 .4.1  Set  PXCEAFTR a rray #9 to  CL-V valu e; if null , set it t o delete " RTN","PXCE C800",27,0 ) S $P(PXC EAFTR(800) ,"^",9)=$P ($G(PXBDAT A(9)),"^", 2) S:$P(PX CEAFTR(800 ),"^",9)=" " $P(PXCEA FTR(800)," ^",9)="@"" RTN","PXCE C800",28,0 ) Q"RTN"," PXCEC800", 29,0) ;"RT N","PXCECC LS")0^17^B 26056884"R TN","PXCEC CLS",1,0)P XCECCLS ;W ASH/BDB -  UPDATE ENC OUNTER SC/ EI FROM DX  SC/EI ;5/ 18/05 1:31 pm"RTN","P XCECCLS",2 ,0) ;;1.0; PCE PATIEN T CARE ENC OUNTER;**1 24,174,168 ,207**;Feb  12, 2004; Build 54"R TN","PXCEC CLS",3,0)  Q"RTN","PX CECCLS",4, 0) ;"RTN", "PXCECCLS" ,5,0)VST(P XVIEN) ;"R TN","PXCEC CLS",6,0)  ;  VISITIE N  Pointer  to the Vi sit (#9000 010)"RTN", "PXCECCLS" ,7,0) ;  L oop over t he diagnos es SC/EI,  auto-popul ate the en counter le vel"RTN"," PXCECCLS", 8,0) ;   S C/EI based  on the fo llowing ru le:"RTN"," PXCECCLS", 9,0) ;   " RTN","PXCE CCLS",10,0 ) ;   If t he SC/EI f or at leas t one ICD- 9 is "Yes" the Encoun ter Level" RTN","PXCE CCLS",11,0 ) ;    SC/ EI will au tomaticall y be set t o "Yes" re gardless i f the"RTN" ,"PXCECCLS ",12,0) ;      Encoun ter Level  SC (or EI)  was previ ously popu lated ("Ye s", "No" o r Null)."R TN","PXCEC CLS",13,0)  ;             Note:  This presu mes that a  single IC D-9 with S C/EI deter mination o f "Yes""RT N","PXCECC LS",14,0)  ;        m akes the E ncounter S C/EI deter mination " Yes""RTN", "PXCECCLS" ,15,0) ;         "RTN ","PXCECCL S",16,0) ;        If  the SC/EI  for all IC D-9s are " No" the En counter Le vel SC/EI  will"RTN", "PXCECCLS" ,17,0) ;        autom atically b e set to " No" regard less if th e Encounte r Level SC /EI"RTN"," PXCECCLS", 18,0) ;        was pr eviously p opulated ( "Yes", "No " or Null) ."RTN","PX CECCLS",19 ,0) ;             Not e: This pr esumes tha t an Encou nter SC/EI  can not b e "Yes" if  all"RTN", "PXCECCLS" ,20,0) ;         ICD- 9s have an  SC/EI det ermination  of "No"." RTN","PXCE CCLS",21,0 ) ;         "RTN","PX CECCLS",22 ,0) ;        If at le ast one IC D-9 is mis sing SC/EI  determina tion and n one of the "RTN","PXC ECCLS",23, 0) ;        other ICD -9s SC/EI  determinat ion is "Ye s" do not  change the  SC/EI"RTN ","PXCECCL S",24,0) ;        det ermination  of the En counter le vel."RTN", "PXCECCLS" ,25,0) ;                   Note:  This pres umes that  if one or  more ICD-9 s do not h ave an SC/ EI"RTN","P XCECCLS",2 6,0) ;        determi nation the n no infer ence can b e made upo n the Enco unter Leve l SC"RTN", "PXCECCLS" ,27,0) ;        deter mination.   In additi on if anot her packag e populate s SC/EI"RT N","PXCECC LS",28,0)  ;       di rectly do  not overwr ite that v alue in th e case of  incomplete "RTN","PXC ECCLS",29, 0) ;        data.  In  other wor ds do not  set the En counter Le vel to Nul l."RTN","P XCECCLS",3 0,0) ;        "RTN"," PXCECCLS", 31,0) ;        VARIAB LE LIST TO  AUTO POPU LATE THE E NCOUNTER L EVEL SC/EI "RTN","PXC ECCLS",32, 0) ;        For each  SC/EI in t he PXSCEIN W string:" RTN","PXCE CCLS",33,0 ) ;                 = 1  SC/EI C lassificat ion determ ined by th e DX's is  found to b e "Yes""RT N","PXCECC LS",34,0)  ;                 =0   SC/EI Cla ssificatio n determin ed by the  DX's is fo und to be  "NO""RTN", "PXCECCLS" ,35,0) ;                  =-1 SC /EI can no t be deter mined by t he DX's"RT N","PXCECC LS",36,0)  ;                 =""  Do not as k the SC/E I question s"RTN","PX CECCLS",37 ,0) ;        "RTN","P XCECCLS",3 8,0) ;        Edit fl ag for SC:  SCEF, AO:  AOEF, IR:  IREF, EC: ECEF, MST:  MSTEF, HN C: HNCEF"R TN","PXCEC CLS",39,0)  ;            , CV: C VEF, SHAD:  SHADEF, C LV: CLVEF   - Used in  Visit Fil e Filing -  See ^VSIT FLD"RTN"," PXCECCLS", 40,0) ;            ex ample belo w           "RTN","PX CECCLS",41 ,0) ;        VIST("SC EF")=1  SC /EI Classi fication d etermined  by the DX' s - do not  ask SC/EI "RTN","PXC ECCLS",42, 0) ;        VIST("SCE F")=0  SC/ EI Classif ication un determined  by the DX 's - ask S C/EI"RTN", "PXCECCLS" ,43,0) ;        etc." RTN","PXCE CCLS",44,0 ) ;              "RTN ","PXCECCL S",45,0) N  PX0,PXDFN ,PXDT,PXCL ,PXPOV,VSI T,PXDFN,PX SCEINW,PXS CEI,PXPOV8 00"RTN","P XCECCLS",4 6,0) ;  dj s  PX*1.0* 207  RSD S PEC #2.6.2 .1.1 & 2.6 .2.1.3  Ad ded 2 "^"  pieces for  total of  9 environm ental indi cators"RTN ","PXCECCL S",47,0) S  PXSCEINW= "^^^^^^^^" "RTN","PXC ECCLS",48, 0) ; Set e ncounter d ata in ^TM P"RTN","PX CECCLS",49 ,0) D ENCE VENT^PXKEN C(PXVIEN)" RTN","PXCE CCLS",50,0 ) ; Get cl assificati ons"RTN"," PXCECCLS", 51,0) S PX DFN=$P($G( ^TMP("PXKE NC",$J,PXV IEN,"VST", PXVIEN,0)) ,U,5)"RTN" ,"PXCECCLS ",52,0) Q: 'PXDFN"RTN ","PXCECCL S",53,0) ; Loop over  DX's"RTN", "PXCECCLS" ,54,0) S P XPOV="" F   S PXPOV=$ O(^TMP("PX KENC",$J,P XVIEN,"POV ",PXPOV))  Q:'PXPOV   D"RTN","PX CECCLS",55 ,0) .S PXP OV800=$G(^ (PXPOV,800 ))"RTN","P XCECCLS",5 6,0) .I '( $P(PXSCEIN W,U,1)="1" )  S:$P(PX POV800,U,1 )="1" $P(P XSCEINW,U, 1)="1" I ' ($P(PXSCEI NW,U,1)<0)   S:$P(PXP OV800,U,1) ="" $P(PXS CEINW,U,1) ="-1" S:$P (PXPOV800, U,1)="0" $ P(PXSCEINW ,U,1)="0"" RTN","PXCE CCLS",57,0 ) .I '($P( PXSCEINW,U ,2)="1")   S:$P(PXPOV 800,U,2)=" 1" $P(PXSC EINW,U,2)= "1" I '($P (PXSCEINW, U,2)<0)  S :$P(PXPOV8 00,U,2)=""  $P(PXSCEI NW,U,2)="- 1" S:$P(PX POV800,U,2 )="0" $P(P XSCEINW,U, 2)="0""RTN ","PXCECCL S",58,0) . I '($P(PXS CEINW,U,3) ="1")  S:$ P(PXPOV800 ,U,3)="1"  $P(PXSCEIN W,U,3)="1"  I '($P(PX SCEINW,U,3 )<0)  S:$P (PXPOV800, U,3)="" $P (PXSCEINW, U,3)="-1"  S:$P(PXPOV 800,U,3)=" 0" $P(PXSC EINW,U,3)= "0""RTN"," PXCECCLS", 59,0) .I ' ($P(PXSCEI NW,U,4)="1 ")  S:$P(P XPOV800,U, 4)="1" $P( PXSCEINW,U ,4)="1" I  '($P(PXSCE INW,U,4)<0 )  S:$P(PX POV800,U,4 )="" $P(PX SCEINW,U,4 )="-1" S:$ P(PXPOV800 ,U,4)="0"  $P(PXSCEIN W,U,4)="0" "RTN","PXC ECCLS",60, 0) .I '($P (PXSCEINW, U,5)="1")   S:$P(PXPO V800,U,5)= "1" $P(PXS CEINW,U,5) ="1" I '($ P(PXSCEINW ,U,5)<0)   S:$P(PXPOV 800,U,5)=" " $P(PXSCE INW,U,5)=" -1" S:$P(P XPOV800,U, 5)="0" $P( PXSCEINW,U ,5)="0""RT N","PXCECC LS",61,0)  .I '($P(PX SCEINW,U,6 )="1")  S: $P(PXPOV80 0,U,6)="1"  $P(PXSCEI NW,U,6)="1 " I '($P(P XSCEINW,U, 6)<0)  S:$ P(PXPOV800 ,U,6)="" $ P(PXSCEINW ,U,6)="-1"  S:$P(PXPO V800,U,6)= "0" $P(PXS CEINW,U,6) ="0""RTN", "PXCECCLS" ,62,0) .I  '($P(PXSCE INW,U,7)=" 1")  S:$P( PXPOV800,U ,7)="1" $P (PXSCEINW, U,7)="1" I  '($P(PXSC EINW,U,7)< 0)  S:$P(P XPOV800,U, 7)="" $P(P XSCEINW,U, 7)="-1" S: $P(PXPOV80 0,U,7)="0"  $P(PXSCEI NW,U,7)="0 ""RTN","PX CECCLS",63 ,0) .I '($ P(PXSCEINW ,U,8)="1")   S:$P(PXP OV800,U,8) ="1" $P(PX SCEINW,U,8 )="1" I '( $P(PXSCEIN W,U,8)<0)   S:$P(PXPO V800,U,8)= "" $P(PXSC EINW,U,8)= "-1" S:$P( PXPOV800,U ,8)="0" $P (PXSCEINW, U,8)="0""R TN","PXCEC CLS",64,0)  .;  djs   PX*1.0*207   RSD SPEC  #2.6.2.1. 1 & 2.6.2. 1.3  Add C amp Lejeun e, piece # 9, to vali dation che cks"RTN"," PXCECCLS", 65,0) .I ' ($P(PXSCEI NW,U,9)="1 ")  S:$P(P XPOV800,U, 9)="1" $P( PXSCEINW,U ,9)="1" I  '($P(PXSCE INW,U,9)<0 )  S:$P(PX POV800,U,9 )="" $P(PX SCEINW,U,9 )="-1" S:$ P(PXPOV800 ,U,9)="0"  $P(PXSCEIN W,U,9)="0" "RTN","PXC ECCLS",66, 0) S VSIT( "IEN")=PXV IEN"RTN"," PXCECCLS", 67,0) ;  d js  PX*1.0 *207  RSD  SPEC #2.6. 2.1.2  Ini tialize Ca mp Lejeune  Edit Flag "RTN","PXC ECCLS",68, 0) S VSIT( "SCEF")=0, VSIT("AOEF ")=0,VSIT( "IREF")=0, VSIT("ECEF ")=0,VSIT( "MSTEF")=0 ,VSIT("HNC EF")=0,VSI T("CVEF")= 0,VSIT("SH ADEF")=0,V SIT("CLVEF ")=0"RTN", "PXCECCLS" ,69,0) S:$ P(PXSCEINW ,U,1)="0"! ($P(PXSCEI NW,U,1)="1 ") VSIT("S C")=$P(PXS CEINW,U,1) ,VSIT("SCE F")=1"RTN" ,"PXCECCLS ",70,0) S: $P(PXSCEIN W,U,2)="0" !($P(PXSCE INW,U,2)=" 1") VSIT(" AO")=$P(PX SCEINW,U,2 ),VSIT("AO EF")=1 S:$ G(VSIT("SC "))=1 VSIT ("AO")="@" "RTN","PXC ECCLS",71, 0) S:$P(PX SCEINW,U,3 )="0"!($P( PXSCEINW,U ,3)="1") V SIT("IR")= $P(PXSCEIN W,U,3),VSI T("IREF")= 1 S:$G(VSI T("SC"))=1  VSIT("IR" )="@""RTN" ,"PXCECCLS ",72,0) S: $P(PXSCEIN W,U,4)="0" !($P(PXSCE INW,U,4)=" 1") VSIT(" EC")=$P(PX SCEINW,U,4 ),VSIT("EC EF")=1 S:$ G(VSIT("SC "))=1 VSIT ("EC")="@" "RTN","PXC ECCLS",73, 0) S:$P(PX SCEINW,U,5 )="0"!($P( PXSCEINW,U ,5)="1") V SIT("MST") =$P(PXSCEI NW,U,5),VS IT("MSTEF" )=1"RTN"," PXCECCLS", 74,0) S:$P (PXSCEINW, U,6)="0"!( $P(PXSCEIN W,U,6)="1" ) VSIT("HN C")=$P(PXS CEINW,U,6) ,VSIT("HNC EF")=1"RTN ","PXCECCL S",75,0) S :$P(PXSCEI NW,U,7)="0 "!($P(PXSC EINW,U,7)= "1") VSIT( "CV")=$P(P XSCEINW,U, 7),VSIT("C VEF")=1"RT N","PXCECC LS",76,0)  S:$P(PXSCE INW,U,8)=" 0"!($P(PXS CEINW,U,8) ="1") VSIT ("SHAD")=$ P(PXSCEINW ,U,8),VSIT ("SHADEF") =1"RTN","P XCECCLS",7 7,0) ;  dj s  PX*1.0* 207  RSD S PEC #2.6.2 .1.1 & 2.6 .2.1.2  Se t Camp Lej eune and C amp Lejeun e Edit Fla g in VISIT  file"RTN" ,"PXCECCLS ",78,0) S: $P(PXSCEIN W,U,9)="0" !($P(PXSCE INW,U,9)=" 1") VSIT(" CLV")=$P(P XSCEINW,U, 9),VSIT("C LVEF")=1 S :$G(VSIT(" SC"))=1 VS IT("CLV")= "@""RTN"," PXCECCLS", 79,0) D UP D^VSIT"RTN ","PXCECCL S",80,0) K  ^TMP("PXK ENC",$J)"R TN","PXCEC CLS",81,0)  Q"RTN","P XCED800")0 ^18^B29219 74"RTN","P XCED800",1 ,0)PXCED80 0 ;WASH/BD B - Used i n editing  the 800 no de, Servic e Connecte d conditio ns ;1/18/0 5 3:33pm"R TN","PXCED 800",2,0)  ;;1.0;PCE  PATIENT CA RE ENCOUNT ER;**124,1 68,207**;A ug 12, 199 6;Build 54 "RTN","PXC ED800",3,0 ) ;; ;"RTN ","PXCED80 0",4,0) Q" RTN","PXCE D800",5,0)  ;"RTN","P XCED800",6 ,0) ;             Cla ssificatio n type 1 -  Agent Ora nge"RTN"," PXCED800", 7,0) ;                                   2  - Ionizing  Radiation "RTN","PXC ED800",8,0 ) ;                                   3 - S ervice Con nected"RTN ","PXCED80 0",9,0) ;                                    4 - SW As ia Conditi ons"RTN"," PXCED800", 10,0) ;                                   5  - Militar y Sexual T rauma"RTN" ,"PXCED800 ",11,0) ;                                    6 - Cance r of the H ead and/or  Neck"RTN" ,"PXCED800 ",12,0) ;                                    7 - Comba t Veteran" RTN","PXCE D800",13,0 ) ;                                   8 - P roject 112 /SHAD"RTN" ,"PXCED800 ",14,0) ;                                    9 - Camp  Lejeune"RT N","PXCED8 00",15,0)G ET800 ;Use d by the S ervice Con nected Con ditions"RT N","PXCED8 00",16,0)  N PXCEINDX ,PXOUT"RTN ","PXCED80 0",17,0) N  PXBDATA,P XLOC,PXAPT DT,PXDFN"R TN","PXCED 800",18,0)  S PXCEDXS C="""RTN", "PXCED800" ,19,0) I $ O(^SCE("AV SIT",PXCEV IEN,0)) D  CLASS^PXBA PI21("","" ,"","",PXC EVIEN)"RTN ","PXCED80 0",20,0) I  '$O(^SCE( "AVSIT",PX CEVIEN,0))  D"RTN","P XCED800",2 1,0) . S P XAPTDT=+^A UPNVSIT(PX CEVIEN,0)" RTN","PXCE D800",22,0 ) . S PXDF N=$P(^AUPN VSIT(PXCEV IEN,0),"^" ,5)"RTN"," PXCED800", 23,0) . S  PXLOC=$P(^ AUPNVSIT(P XCEVIEN,0) ,"^",22)"R TN","PXCED 800",24,0)  . D CLASS ^PXBAPI21( "",PXDFN,P XAPTDT,PXL OC,"")"RTN ","PXCED80 0",25,0) ;   djs  PX* 1.0*207  R SD SPEC #2 .6.2.4.4.1   Increase d FOR loop  for Camp  Lejeune"RT N","PXCED8 00",26,0)  F PXCEINDX =1:1:9 I $ G(PXBDATA( "ERR",PXCE INDX))=4 S  PXOUT=PXB DATA("ERR" ,PXCEINDX) "RTN","PXC ED800",27, 0) I $D(PX OUT) S PXC EEND=1 Q"R TN","PXCED 800",28,0)  S $P(PXCE DXSC,"^",1 )=$P($G(PX BDATA(3)), "^",2)"RTN ","PXCED80 0",29,0) ;   djs  PX* 1.0*207  R SD SPEC #2 .6.2.4.4.1   Add Camp  Lejeune t o indicato rs that ca n't be =YE S if SC=YE S"RTN","PX CED800",30 ,0) I +PXC EDXSC S (P XDATA(1),P XDATA(2),P XDATA(4),P XDATA(9))= "^^""RTN", "PXCED800" ,31,0) S $ P(PXCEDXSC ,"^",2)=$P ($G(PXBDAT A(1)),"^", 2)"RTN","P XCED800",3 2,0) S $P( PXCEDXSC," ^",3)=$P($ G(PXBDATA( 2)),"^",2) "RTN","PXC ED800",33, 0) S $P(PX CEDXSC,"^" ,4)=$P($G( PXBDATA(4) ),"^",2)"R TN","PXCED 800",34,0)  S $P(PXCE DXSC,"^",5 )=$P($G(PX BDATA(5)), "^",2)"RTN ","PXCED80 0",35,0) S  $P(PXCEDX SC,"^",6)= $P($G(PXBD ATA(6)),"^ ",2)"RTN", "PXCED800" ,36,0) S $ P(PXCEDXSC ,"^",7)=$P ($G(PXBDAT A(7)),"^", 2)"RTN","P XCED800",3 7,0) S $P( PXCEDXSC," ^",8)=$P($ G(PXBDATA( 8)),"^",2) "RTN","PXC ED800",38, 0) ;  djs   PX*1.0*20 7  RSD SPE C #2.6.2.4 .4.1  Set  PXCEDXSC a rray #9 to  CL-V valu e "RTN","P XCED800",3 9,0) S $P( PXCEDXSC," ^",9)=$P($ G(PXBDATA( 9)),"^",2) "RTN","PXC ED800",40, 0) Q"RTN", "PXCED800" ,41,0) ;"R TN","PXCEE 800")0^19^ B2266029"R TN","PXCEE 800",1,0)P XCEE800 ;I SL/dee,ISA /KWP - Use d in editi ng the 800  node, Ser vice Conne cted condi tions ;06/ 06/05"RTN" ,"PXCEE800 ",2,0) ;;1 .0;PCE PAT IENT CARE  ENCOUNTER; **74,111,1 30,168,207 **;Aug 12,  1996;Buil d 54"RTN", "PXCEE800" ,3,0) ;; ; "RTN","PXC EE800",4,0 ) Q"RTN"," PXCEE800", 5,0) ;"RTN ","PXCEE80 0",6,0)GET 800 ;Used  by all the  Service C onnected C onditions" RTN","PXCE E800",7,0)  ;Do not a sk if not  primary vi sit."RTN", "PXCEE800" ,8,0) Q:$P (PXCEAFTR( 0),"^",22) '>0"RTN"," PXCEE800", 9,0) Q:$P( PXCEAFTR(0 ),"^",8)'= $P(^SC($P( PXCEAFTR(0 ),"^",22), 0),"^",7)" RTN","PXCE E800",10,0 ) N PXCEIN DX,PXOUT"R TN","PXCEE 800",11,0)  N PXBDATA "RTN","PXC EE800",12, 0) D CLASS ^PXBAPI21( "",PXCEPAT ,+PXCEAFTR (0),$P(PXC EAFTR(0)," ^",22),PXC EFIEN)"RTN ","PXCEE80 0",13,0) ; PX*1*111 -  Add HNC"R TN","PXCEE 800",14,0)  ;  djs  P X*1.0*207   RSD SPEC  #2.6.2.4.4 .1  Increa sed FOR lo op for Cam p Lejeune" RTN","PXCE E800",15,0 ) F PXCEIN DX=1:1:9 I  $G(PXBDAT A("ERR",PX CEINDX))=4  S PXOUT=P XBDATA("ER R",PXCEIND X)"RTN","P XCEE800",1 6,0) I $D( PXOUT) S ( PXCEEND,PX CEQUIT)=1  Q  ;for vi sit and re quired fie lds"RTN"," PXCEE800", 17,0) S $P (PXCEAFTR( 800),"^",1 )=$P($G(PX BDATA(3)), "^",2)"RTN ","PXCEE80 0",18,0) S  $P(PXCEAF TR(800),"^ ",2)=$P($G (PXBDATA(1 )),"^",2)" RTN","PXCE E800",19,0 ) S $P(PXC EAFTR(800) ,"^",3)=$P ($G(PXBDAT A(2)),"^", 2)"RTN","P XCEE800",2 0,0) S $P( PXCEAFTR(8 00),"^",4) =$P($G(PXB DATA(4))," ^",2)"RTN" ,"PXCEE800 ",21,0) S  $P(PXCEAFT R(800),"^" ,5)=$P($G( PXBDATA(5) ),"^",2)"R TN","PXCEE 800",22,0)  ;PX*1*111  - Add HNC "RTN","PXC EE800",23, 0) S $P(PX CEAFTR(800 ),"^",6)=$ P($G(PXBDA TA(6)),"^" ,2)"RTN"," PXCEE800", 24,0) S $P (PXCEAFTR( 800),"^",7 )=$P($G(PX BDATA(7)), "^",2)"RTN ","PXCEE80 0",25,0) S  $P(PXCEAF TR(800),"^ ",8)=$P($G (PXBDATA(8 )),"^",2)" RTN","PXCE E800",26,0 ) ;  djs   PX*1.0*207   RSD SPEC  #2.6.2.4. 4.1  Set P XCEAFTR ar ray #9 to  CL-V value  "RTN","PX CEE800",27 ,0) S $P(P XCEAFTR(80 0),"^",9)= $P($G(PXBD ATA(9)),"^ ",2)"RTN", "PXCEE800" ,28,0) Q"R TN","PXCEE 800",29,0)  ;"RTN","P XCEPOV")0^ 20^B146059 90"RTN","P XCEPOV",1, 0)PXCEPOV  ;ISL/dee -  Used to e dit and di splay V PO V ;24 May  2013  8:53  AM"RTN"," PXCEPOV",2 ,0) ;;1.0; PCE PATIEN T CARE ENC OUNTER;**2 7,121,124, 170,168,19 9,207**;Au g 12, 1996 ;Build 54" RTN","PXCE POV",3,0)  ;; ;"RTN", "PXCEPOV", 4,0) ;"RTN ","PXCEPOV ",5,0) ; R eference t o LD^ICDEX  supported  by ICR #5 747"RTN"," PXCEPOV",6 ,0) ;"RTN" ,"PXCEPOV" ,7,0) Q"RT N","PXCEPO V",8,0) ;" RTN","PXCE POV",9,0)  ;Line with  the line  label "FOR MAT""RTN", "PXCEPOV", 10,0) ;;Lo ng name~Fi le Number~ Node Subsc ripts~Allo w Duplicat e entries  (1=yes, 0= no)~File g lobal name "RTN","PXC EPOV",11,0 ) ;     1          2               3                     4                                      5" RTN","PXCE POV",12,0)  ;"RTN","P XCEPOV",13 ,0) ;Follo wing lines :"RTN","PX CEPOV",14, 0) ;;Node~ Piece~,Fie ld Number~ Edit Label ~Display L abel~Displ ay Routine ~Edit Rout ine~Help T ext for DI R(?)~Set o f PXCEKEYS  that can  Edit~D if  Detail Dis play Only~ "RTN","PXC EPOV",15,0 ) ;  1  ~   2  ~       3      ~      4    ~         5     ~         6      ~      7       ~        8             ~           9                    ~        10"RTN"," PXCEPOV",1 6,0) ;The  Display &  Edit routi nes are fo r special  cases."RTN ","PXCEPOV ",17,0) ;   (The .01  field cann ot have a  special ed it.)"RTN", "PXCEPOV", 18,0) ;"RT N","PXCEPO V",19,0)FO RMAT ;;Dia gnosis~900 0010.07~0, 12,800,802 ,811,812~1 ~^AUPNVPOV "RTN","PXC EPOV",20,0 ) ;;0~1~.0 1~ICD Code  or Diagno sis:  ~ICD  Code or D iagnosis:   ~$$DISPLY 01^PXCEPOV ~ICDCODE^P XCEPOV1~^D  HELP^PXCE HELP~~B"RT N","PXCEPO V",21,0) ; ;0~4~.04~P rovider Na rrative:   ~Provider  Narrative:   ~$$DNARR AT^PXCEPOV 1~ENARRAT^ PXCEPOV1(1 ,1,1,80,10 ,3)~~~B"RT N","PXCEPO V",22,0) ; ;0~12~.12~ Is this Di agnosis Pr imary for  the Encoun ter:  ~Pri mary/Secon dary Diagn osis for t he Encount er:  ~$$DP RIMSEC^PXC EPOV1~EPRI MSEC^PXCEP RV~~~B"RTN ","PXCEPOV ",23,0) ;; 0~17~.17~I s this Dia gnosis Ord ering, Res ulting, or  Both:  ~O rdering/Re sulting Di agnosis:   ~~~~~B"RTN ","PXCEPOV ",24,0) ;; 0~6~.06~Mo difier:  ~ Modifier:   ~~~~~D"RT N","PXCEPO V",25,0) ; ;0~13~.13~ Injury Dat e and (opt ional) Tim e~Date of  Injury:  ~ ~EINJURY^P XCEPOV1~~~ D"RTN","PX CEPOV",26, 0) ;;12~4~ 1204~Encou nter Provi der:  ~Enc ounter Pro vider:  ~~ EPROV12^PX CEPRV~~~D" RTN","PXCE POV",27,0)  ;;802~1~8 0201~Provi der Narrat ive Catego ry:  ~Prov ider Narra tive Categ ory:  ~$$D NARRAT^PXC EPOV1~ENAR RAT^PXCEPO V1(0,2,0,8 0,5)~~C~D" RTN","PXCE POV",28,0)  ;;811~1~8 1101~Comme nts:  ~Com ments:  ~~ ~~~D"RTN", "PXCEPOV", 29,0) ;;80 0~1~80001~ Service Co nnected:   ~Service C onnected:   ~~GET800^ PXCEC800~~ ~D"RTN","P XCEPOV",30 ,0) ;;800~ 7~80007~Co mbat Veter an:  ~Comb at Veteran :  ~~SKIP^ PXCEPOV~~~ D"RTN","PX CEPOV",31, 0) ;;800~2 ~80002~Age nt Orange  Exposure:   ~Agent Or ange Expos ure:  ~~SK IP^PXCEPOV ~~~D"RTN", "PXCEPOV", 32,0) ;;80 0~3~80003~ Ionizing R adiation E xposure:   ~Ionizing  Radiation  Exposure:   ~~SKIP^PX CEPOV~~~D" RTN","PXCE POV",33,0)  ;;800~4~8 0004~SW As ia Conditi ons:  ~SW  Asia Condi tions:  ~~ SKIP^PXCEP OV~~~D"RTN ","PXCEPOV ",34,0) ;; 800~8~8000 8~Project  112/SHAD:   ~Project  112/SHAD:   ~~SKIP^PX CEPOV~~~D" RTN","PXCE POV",35,0)  ;;800~5~8 0005~Milit ary Sexual  Trauma:   ~Military  Sexual Tra uma:  ~~SK IP^PXCEPOV ~~~D"RTN", "PXCEPOV", 36,0) ;;80 0~6~80006~ Head and/o r Neck Can cer:  ~Hea d and/or N eck Cancer :  ~~SKIP^ PXCEPOV~~~ D"RTN","PX CEPOV",37, 0) ;;800~9 ~80009~Cam p Lejeune  Exposure:   ~Camp Lej eune Expos ure:  ~~SK IP^PXCEPOV ~~~D"RTN", "PXCEPOV", 38,0) ;  d js  PX*1.0 *207  RSD  SPEC #2.6. 2.4.4.1  A dded Camp  Lejeune as  a new ite m when edi ting and d isplaying  a visit"RT N","PXCEPO V",39,0) ; "RTN","PXC EPOV",40,0 ) ;"RTN"," PXCEPOV",4 1,0) ;"RTN ","PXCEPOV ",42,0) ;T he interfa ce for AIC S to get l ist on for m for help ."RTN","PX CEPOV",43, 0)INTRFACE  ;;DG SELE CT ICD DIA GNOSIS COD ES"RTN","P XCEPOV",44 ,0) ;"RTN" ,"PXCEPOV" ,45,0) ;** ********** ********** ********** "RTN","PXC EPOV",46,0 ) ;Special  cases for  display." RTN","PXCE POV",47,0)  ;"RTN","P XCEPOV",48 ,0) ;***** ********** ********** *******"RT N","PXCEPO V",49,0) ; Display te xt for the  .01 field  which is  a pointer  to ^ICD9." RTN","PXCE POV",50,0)  ;(Must ha ve is call ed by ASK^ PXCEVFI2 a nd DEL^PXC EVFI2.)"RT N","PXCEPO V",51,0)DI SPLY01(PXC EPOV) ;"RT N","PXCEPO V",52,0) N  ICDSTR,PX DXDATE"RTN ","PXCEPOV ",53,0) S  PXDXDATE=$ $CSDATE^PX DXUTL(PXCE VIEN)"RTN" ,"PXCEPOV" ,54,0) S I CDSTR=$$IC DDATA^ICDX CODE("DIAG ",$P(PXCEP OV,"^"),PX DXDATE,"I" )"RTN","PX CEPOV",55, 0) I $P(IC DSTR,U,20) '=30 Q $P( ICDSTR,"^" ,2)_"      "_$P(ICDST R,"^",4) ; code and d esc"RTN"," PXCEPOV",5 6,0) I $P( ICDSTR,U,2 0)=30 Q $P (ICDSTR,"^ ",2)_"      "_$$SENTE NCE^XLFSTR ($$LD^ICDE X(80,$P(PX CEPOV,"^") ,PXDXDATE) )   ; code  and long  desc"RTN", "PXCEPOV", 57,0) ;"RT N","PXCEPO V",58,0)SK IP ;"RTN", "PXCEPOV", 59,0) Q"RT N","PXCESI T")0^21^B1 0473456"RT N","PXCESI T",1,0)PXC ESIT ;ISL/ dee,ISA/KW P - Used t o edit a n ew visit a nd display  (use most ) a visit  ;3/17/04 1 2:10pm"RTN ","PXCESIT ",2,0) ;;1 .0;PCE PAT IENT CARE  ENCOUNTER; **22,74,11 1,130,124, 168,207**; Aug 12, 19 96;Build 5 4"RTN","PX CESIT",3,0 ) ;+ The c lassificat ions show  in the Dis play Detai l Protocol "RTN","PXC ESIT",4,0)  Q"RTN","P XCESIT",5, 0) ;"RTN", "PXCESIT", 6,0) ;Line  with the  line label  "FORMAT"" RTN","PXCE SIT",7,0)  ;;Long nam e~File Num ber~Node S ubscripts~ Allow Dupl icate entr ies (not u sed on vis it)~File g lobal name "RTN","PXC ESIT",8,0)  ;     1          2               3                     4                                            5"RTN"," PXCESIT",9 ,0) ;"RTN" ,"PXCESIT" ,10,0) ;Fo llowing li nes:"RTN", "PXCESIT", 11,0) ;;No de~Piece~, Field Numb er~Edit La bel~Displa y Label~Di splay Rout ine~Edit R outine~Hel p Text for  DIR("?")~ Set of PXC EKEYS that  can Edit~ D if Detai l Display  Only~"RTN" ,"PXCESIT" ,12,0) ;   1  ~  2  ~       3       ~     4     ~         5    ~         6       ~      7      ~        8                ~           9                    ~       10 "RTN","PXC ESIT",13,0 ) ;The Dis play & Edi t routines  are for s pecial cas es."RTN"," PXCESIT",1 4,0) ;"RTN ","PXCESIT ",15,0)FOR MAT ;;Enco unter~9000 010~0,21,1 50,800,811 ,812~~^AUP NVSIT"RTN" ,"PXCESIT" ,16,0) ;;0 ~1~.01~Enc ounter Dat e and Time :  ~Encoun ter Date a nd Time:   ~~EVISITDT ^PXCEVSIT( 1)~~~B"RTN ","PXCESIT ",17,0) ;; 0~5~.05~Pa tient Name :  ~Patien t Name:  ~ ~EPAT^PXCE VSIT~~~D"R TN","PXCES IT",18,0)  ;;0~22~.22 ~Hospital  Location:   ~Hospital  Location:   ~~EHOSPL OC^PXCEVSI T~^D HELPH LOC^PXCEVS IT~~D"RTN" ,"PXCESIT" ,19,0) ;;0 ~8~.08~Cli nic Stop:   ~Clinic S top:  ~$$D ISPLY08^PX CECSTP~EWO RKLOD^PXCE VSIT(0)~~~ D"RTN","PX CESIT",20, 0) ;;0~18~ .18~Check  Out ~Check  Out Date  and Time:   ~~ECODT^P XCEVSIT~~~ D"RTN","PX CESIT",21, 0) ;;800~1 ~80001~Ser vice Conne cted:  ~Se rvice Conn ected:  ~~ SKIP^PXCEV SIT~~~D"RT N","PXCESI T",22,0) ; ;800~7~800 07~Combat  Veteran:   ~Combat Ve teran:  ~~ SKIP^PXCEV SIT~~~D"RT N","PXCESI T",23,0) ; ;800~2~800 02~Agent O range Expo sure:  ~Ag ent Orange  Exposure:   ~~SKIP^P XCEVSIT~~~ D"RTN","PX CESIT",24, 0) ;;800~3 ~80003~Ion izing Radi ation Expo sure:  ~Io nizing Rad iation Exp osure:  ~~ SKIP^PXCEV SIT~~~D"RT N","PXCESI T",25,0) ; ;800~4~800 04~SW Asia  Condition s:  ~SW As ia Conditi ons:  ~~SK IP^PXCEVSI T~~~D"RTN" ,"PXCESIT" ,26,0) ;;8 00~8~80008 ~Project 1 12/SHAD:   ~Project 1 12/SHAD:   ~~SKIP^PXC EVSIT~~~D" RTN","PXCE SIT",27,0)  ;;800~5~8 0005~Milit ary Sexual  Trauma:   ~Military  Sexual Tra uma:  ~~SK IP^PXCEVSI T~~~D"RTN" ,"PXCESIT" ,28,0) ;;8 00~6~80006 ~Head and/ or Neck Ca ncer:  ~He ad and/or  Neck Cance r:  ~~SKIP ^PXCEVSIT~ ~~D"RTN"," PXCESIT",2 9,0) ;;800 ~9~80009~C amp Lejeun e Exposure :  ~Camp L ejeune Exp osure:  ~~ SKIP^PXCEV SIT~~~D"RT N","PXCESI T",30,0) ;   djs  PX* 1.0*207  R SD SPEC #2 .6.2.4.4.1   Added Ca mp Lejeune  as a new  item when  displaying  visit"RTN ","PXCESIT ",31,0) ;; "RTN","PXC ESIT",32,0 ) ;"RTN"," PXCESIT",3 3,0) ;**** ********** ********** ********"R TN","PXCES IT",34,0)  ;Special c ases for d isplay of  visit are  in PXCEVSI T."RTN","P XCESIT",35 ,0) ;"RTN" ,"PXCESIT" ,36,0) ;** ********** ********** ********** "RTN","PXC ESIT",37,0 ) ;Special  cases for  edit of v isit are i n PXCEVSIT ."RTN","PX CESIT",38, 0) ;"RTN", "PXCESIT", 39,0) ;*** ********** ********** *********" RTN","PXCE SIT",40,0)  ;Display  text for t he .01 fie ld which i s a Date a nd Time."R TN","PXCES IT",41,0)  ;(Must hav e is calle d by ASK^P XCEVFI2 an d DEL^PXCE VFI2.)"RTN ","PXCESIT ",42,0)DIS PLY01(PXCE VSIT) ;"RT N","PXCESI T",43,0) N  DIERR,PXC EDILF,PXCE INT,PXCEEX T"RTN","PX CESIT",44, 0) N TEXT" RTN","PXCE SIT",45,0)  S PXCEINT =$P(PXCEVS IT,"^",1)" RTN","PXCE SIT",46,0)  S PXCEEXT =$$EXTERNA L^DILFD(90 00010,.01, "",PXCEINT ,"PXCEDILF ")"RTN","P XCESIT",47 ,0) S TEXT =$S('$D(DI ERR):PXCEE XT,1:PXCEI NT)"RTN"," PXCESIT",4 8,0) S PXC EINT=$P(PX CEVSIT,"^" ,22)"RTN", "PXCESIT", 49,0) S PX CEEXT=$$EX TERNAL^DIL FD(9000010 ,.22,"",PX CEINT,"PXC EDILF")"RT N","PXCESI T",50,0) S  TEXT=TEXT _"   "_$S( '$D(DIERR) :PXCEEXT,1 :PXCEINT)" RTN","PXCE SIT",51,0)  S PXCEINT =$P(PXCEVS IT,"^",8)" RTN","PXCE SIT",52,0)  S PXCEEXT =$$EXTERNA L^DILFD(90 00010,.08, "",PXCEINT ,"PXCEDILF ")"RTN","P XCESIT",53 ,0) S TEXT =TEXT_"    "_$S('$D(D IERR):PXCE EXT,1:PXCE INT)"RTN", "PXCESIT", 54,0) Q TE XT"RTN","P XCESIT",55 ,0) ;"RTN" ,"PXCEVST" )0^22^B700 1683"RTN", "PXCEVST", 1,0)PXCEVS T ;ISL/dee ,ISA/KWP -  Used to e dit a visi t and disp lay a visi t ;04/8/99 "RTN","PXC EVST",2,0)  ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**22,7 4,111,130, 124,168,20 7**;Aug 12 , 1996;Bui ld 54"RTN" ,"PXCEVST" ,3,0) ;; ; "RTN","PXC EVST",4,0)  Q"RTN","P XCEVST",5, 0) ;"RTN", "PXCEVST", 6,0) ;Line  with the  line label  "FORMAT"" RTN","PXCE VST",7,0)  ;;Long nam e~File Num ber~Node S ubscripts~ Allow Dupl icate entr ies (not u sed on vis it)~File g lobal name "RTN","PXC EVST",8,0)  ;     1          2               3                     4                                            5"RTN"," PXCEVST",9 ,0) ;"RTN" ,"PXCEVST" ,10,0) ;Fo llowing li nes:"RTN", "PXCEVST", 11,0) ;;No de~Piece~, Field Numb er~Edit La bel~Displa y Label~Di splay Rout ine~Edit R outine~Hel p Text for  DIR("?")~ Set of PXC EKEYS that  can Edit~ D if Detai l Display  Only~"RTN" ,"PXCEVST" ,12,0) ;   1  ~  2  ~       3       ~     4     ~         5    ~         6       ~      7      ~        8                ~           9                    ~       10 "RTN","PXC EVST",13,0 ) ;The Dis play & Edi t routines  are for s pecial cas es."RTN"," PXCEVST",1 4,0) ;"RTN ","PXCEVST ",15,0)FOR MAT ;;Enco unter~9000 010~0,21,1 50,800,811 ,812~~^AUP NVSIT"RTN" ,"PXCEVST" ,16,0) ;;0 ~1~.01~Enc ounter Dat e and Time :  ~Encoun ter Date a nd Time:   ~~EVISITDT ^PXCEVSIT( 1)~~~B"RTN ","PXCEVST ",17,0) ;; 0~18~.18~C heck Out ~ Check Out  Date and T ime:  ~~EC ODT^PXCEVS IT~~~D"RTN ","PXCEVST ",18,0) ;; 800~1~8000 1~Service  Connected:   ~Service  Connected :  ~~GET80 0^PXCEE800 ~~~D"RTN", "PXCEVST", 19,0) ;;80 0~7~80007~ Combat Vet eran:  ~Co mbat Veter an:  ~~SKI P^PXCEVSIT ~~~D"RTN", "PXCEVST", 20,0) ;;80 0~2~80002~ Agent Oran ge Exposur e:  ~Agent  Orange Ex posure:  ~ ~SKIP^PXCE VSIT~~~D"R TN","PXCEV ST",21,0)  ;;800~3~80 003~Ionizi ng Radiati on Exposur e:  ~Ioniz ing Radiat ion Exposu re:  ~~SKI P^PXCEVSIT ~~~D"RTN", "PXCEVST", 22,0) ;;80 0~4~80004~ SW Asia Co nditions:   ~SW Asia  Conditions :  ~~SKIP^ PXCEVSIT~~ ~D"RTN","P XCEVST",23 ,0) ;;800~ 8~80008~Pr oject 112/ SHAD:  ~Pr oject 112/ SHAD:  ~~S KIP^PXCEVS IT~~~D"RTN ","PXCEVST ",24,0) ;; 800~5~8000 5~Military  Sexual Tr auma:  ~Mi litary Sex ual Trauma :  ~~SKIP^ PXCEVSIT~~ ~D"RTN","P XCEVST",25 ,0) ;;800~ 6~80006~He ad and/or  Neck Cance r:  ~Head  and/or Nec k Cancer:   ~~SKIP^PX CEVSIT~~~D "RTN","PXC EVST",26,0 ) ;;800~9~ 80009~Camp  Lejeune E xposure:   ~Camp Leje une Exposu re:  ~~SKI P^PXCEVSIT ~~~D"RTN", "PXCEVST", 27,0) ;  d js  PX*1.0 *207  RSD  SPEC #2.6. 2.4.4.1  A dded Camp  Lejeune as  a new ite m when edi ting or di splaying v isit"RTN", "PXCEVST", 28,0) ;"RT N","PXCEVS T",29,0) ; "RTN","PXC EVST",30,0 ) ;"RTN"," PXCEVST",3 1,0) ;**** ********** ********** ********"R TN","PXCEV ST",32,0)  ;Special c ases for d isplay of  visit are  in PXCEVSI T."RTN","P XCEVST",33 ,0) ;"RTN" ,"PXCEVST" ,34,0) ;** ********** ********** ********** "RTN","PXC EVST",35,0 ) ;Special  cases for  edit of v isit are i n PXCEVSIT ."RTN","PX CEVST",36, 0) ;"RTN", "PXCEVST", 37,0) ;*** ********** ********** *********" RTN","PXCE VST",38,0)  ;Display  text for t he .01 fie ld which i s a Date a nd Time."R TN","PXCEV ST",39,0)  ;(Must hav e is calle d by ASK^P XCEVFI2 an d DEL^PXCE VFI2.)"RTN ","PXCEVST ",40,0)DIS PLY01(PXCE VSIT) ;"RT N","PXCEVS T",41,0) Q  $$DISPLY0 1^PXCESIT( PXCEVSIT)" RTN","PXCE VST",42,0)  ;"RTN","P XKFPOV")0^ 42^B404263 5"RTN","PX KFPOV",1,0 )PXKFPOV ; ISL/JVS -  Fields for  V PURPOSE  OF VISIT  (POV) file  ;3/1/04 1 0:46am"RTN ","PXKFPOV ",2,0) ;;1 .0;PCE PAT IENT CARE  ENCOUNTER; **22,130,1 24,168,207 **;Aug 12,  1996;Buil d 54"RTN", "PXKFPOV", 3,0) ;"RTN ","PXKFPOV ",4,0) ;   Adding or  Editing of  data in a  particula r field ca n be contr olled"RTN" ,"PXKFPOV" ,5,0) ;by  adding a ~  as a deli miter and  the letter s A and/or  E to the" RTN","PXKF POV",6,0)  ;end of th e line of  text which  represent s what cou ld be adde d"RTN","PX KFPOV",7,0 ) ;to the  DR string  in a DIE c all."RTN", "PXKFPOV", 8,0) ; 1.  If none or  all three (~AE) of t hese chara cters are  added then "RTN","PXK FPOV",9,0)  ;    the  data in th is field c an be eith er added o r edited." RTN","PXKF POV",10,0)  ; 2. If o nly the ~  is added t hen the da ta in this  field can  be"RTN"," PXKFPOV",1 1,0) ;     neither ad ded or edi ted."RTN", "PXKFPOV", 12,0) ; 3.  IF only t he ~A is a dded then  the data c an only be  added to" RTN","PXKF POV",13,0)  ;    the  file for t his field  but not ed ited."RTN" ,"PXKFPOV" ,14,0) ; 4 . If only  the ~E is  added the  the data c an only be  edited in "RTN","PXK FPOV",15,0 ) ;    thi s file for  this fiel d. (not a  likely pos sibility)" RTN","PXKF POV",16,0)  ;"RTN","P XKFPOV",17 ,0) ; The  word "OPTI ON" in fro nt of the  line of te xt below t ells the " RTN","PXKF POV",18,0)  ;software  to determ ine,based  on the dat a, the app ropriatene ss"RTN","P XKFPOV",19 ,0) ;of us ing either  a "///" o r "////" s tuff in a  DIE call." RTN","PXKF POV",20,0)  ;"RTN","P XKFPOV",21 ,0) ; The  informatio n on line  tag 0 $P(, ," * ",1)  are the pi ece number s"RTN","PX KFPOV",22, 0) ;of the  fields on  the zero  node that  are requir ed by the  data"RTN", "PXKFPOV", 23,0) ;dic tionary an d are chec ked for to  determine  if enough  data is p resent"RTN ","PXKFPOV ",24,0) ;t o proceed  without an y errors.  $P(,," * " ,2) are th e nodes an d"RTN","PX KFPOV",25, 0) ;piece  numbers of  the field s used to  determine  duplicates  in the"RT N","PXKFPO V",26,0) ; file (node +piece (eg . 12+4)).  $P(,," * " ,3) is a f lag use to "RTN","PXK FPOV",27,0 ) ;determi ne if dupl icates are  allowed i n this vis it file. " RTN","PXKF POV",28,0)  ;If it is  set to 0  then no du plicate ch ecks will  occur. If  it is"RTN" ,"PXKFPOV" ,29,0) ;se t to 1 the n the file  will be c hecked for  duplicate s based on "RTN","PXK FPOV",30,0 ) ;the inf ormation i n $P 2."RT N","PXKFPO V",31,0) ; "RTN","PXK FPOV",32,0 ) ; The fo llowing is  the file' s global n ame.  Each  global mu st have a" RTN","PXKF POV",33,0)  ;unique n ame and ca n not have  any subsc ripts as p art of the  global ro ot."RTN"," PXKFPOV",3 4,0)GLOBAL  ;;^AUPNVP OV"RTN","P XKFPOV",35 ,0) ;"RTN" ,"PXKFPOV" ,36,0)EN1  ;"RTN","PX KFPOV",37, 0) S PXKER ="""RTN"," PXKFPOV",3 8,0) S PXK ER=$P($T(@ PXKNOD+PXK PCE),";;", 2) Q"RTN", "PXKFPOV", 39,0)EN2 ; "RTN","PXK FPOV",40,0 ) S PXKFD= """RTN","P XKFPOV",41 ,0) S PXKF D=$P($T(@P XKNOD+PXKP CE),";;",2 ) D"RTN"," PXKFPOV",4 2,0) .I PX KFD="" S P XKPCE=PXKP CE+1 D EN2 "RTN","PXK FPOV",43,0 ) Q"RTN"," PXKFPOV",4 4,0)ADD ;A dd an entr y to the f ile"RTN"," PXKFPOV",4 5,0) Q"RTN ","PXKFPOV ",46,0)0 ; ;1,2,3,4 *  0+1,0+3 *  1"RTN","P XKFPOV",47 ,0) ;;.01/ ///^S X=$G ("RTN","PX KFPOV",48, 0) ;;.02// //^S X=$G( "RTN","PXK FPOV",49,0 ) ;;.03/// /^S X=$G(" RTN","PXKF POV",50,0)  ;;OPTION  * .04////^ S X=$G( *  .04///^S X =$G("RTN", "PXKFPOV", 51,0) ;;.0 5///^S X=$ G("RTN","P XKFPOV",52 ,0) ;;.06/ //^S X=$G( "RTN","PXK FPOV",53,0 ) ;;.07/// ^S X=$G("R TN","PXKFP OV",54,0)  ;;.08///^S  X=$G("RTN ","PXKFPOV ",55,0) ;; .09////^S  X=$G("RTN" ,"PXKFPOV" ,56,0) ;;" RTN","PXKF POV",57,0)  ;;.11///^ S X=$G("RT N","PXKFPO V",58,0) ; ;.12///^S  X=$G("RTN" ,"PXKFPOV" ,59,0) ;;. 13///^S X= $G("RTN"," PXKFPOV",6 0,0) ;;.14 ////^S X=$ G("RTN","P XKFPOV",61 ,0) ;;.15/ ///^S X=$G ("RTN","PX KFPOV",62, 0) ;;.16// //^S X=$G( "RTN","PXK FPOV",63,0 ) ;;.17/// ^S X=$G("R TN","PXKFP OV",64,0)1 2 ;;"RTN", "PXKFPOV", 65,0) ;;12 01////^S X =$G("RTN", "PXKFPOV", 66,0) ;;12 02////^S X =$G("RTN", "PXKFPOV", 67,0) ;;"R TN","PXKFP OV",68,0)  ;;1204//// ^S X=$G("R TN","PXKFP OV",69,0)  ;;"RTN","P XKFPOV",70 ,0) ;;"RTN ","PXKFPOV ",71,0)800  ;;"RTN"," PXKFPOV",7 2,0) ;;800 01///^S X= $G("RTN"," PXKFPOV",7 3,0) ;;800 02///^S X= $G("RTN"," PXKFPOV",7 4,0) ;;800 03///^S X= $G("RTN"," PXKFPOV",7 5,0) ;;800 04///^S X= $G("RTN"," PXKFPOV",7 6,0) ;;800 05///^S X= $G("RTN"," PXKFPOV",7 7,0) ;;800 06///^S X= $G("RTN"," PXKFPOV",7 8,0) ;;800 07///^S X= $G("RTN"," PXKFPOV",7 9,0) ;;800 08///^S X= $G("RTN"," PXKFPOV",8 0,0) ;;800 09///^S X= $G("RTN"," PXKFPOV",8 1,0) ;  dj s  PX*1.0* 207  RSD S PEC #2.6.2 .1.3  Adde d field nu mber for C amp Lejeun e enhancem ent "RTN", "PXKFPOV", 82,0)801 ; ;"RTN","PX KFPOV",83, 0) ;;80101 ///^S X=1; "RTN","PXK FPOV",84,0 ) ;;80102/ //^S X=$G( PXKAUDIT); "RTN","PXK FPOV",85,0 )802 ;;"RT N","PXKFPO V",86,0) ; ;OPTION *  80201////^ S X=$G( *  80201///^S  X=$G("RTN ","PXKFPOV ",87,0)811  ;;"RTN"," PXKFPOV",8 8,0) ;;811 01///^S X= $G("RTN"," PXKFPOV",8 9,0)812 ;; "RTN","PXK FPOV",90,0 ) ;;81201/ //^S X=$G( "RTN","PXK FPOV",91,0 ) ;;81202/ ///^S X=$G ("RTN","PX KFPOV",92, 0) ;;81203 ////^S X=$ G("RTN","P XKFPOV",93 ,0)SPEC ;" RTN","PXKF POV",94,0)  Q"RTN","P XKFVST")0^ 23^B140555 12"RTN","P XKFVST",1, 0)PXKFVST  ;ISL/JVS -  Fields fo r VISIT fi le ;7/29/9 6"RTN","PX KFVST",2,0 ) ;;1.0;PC E PATIENT  CARE ENCOU NTER;**22, 56,111,130 ,124,164,1 68,207**;A ug 12, 199 6;Build 54 "RTN","PXK FVST",3,0)  ;"RTN","P XKFVST",4, 0) ;  Addi ng or Edit ing of dat a in a par ticular fi eld can be  controlle d"RTN","PX KFVST",5,0 ) ;by addi ng a ~ as  a delimite r and the  letters A  and/or E t o the"RTN" ,"PXKFVST" ,6,0) ;end  of the li ne of text  which rep resents wh at could b e added"RT N","PXKFVS T",7,0) ;t o the DR s tring in a  DIE call. "RTN","PXK FVST",8,0)  ; 1. If n one or all  three(~AE ) of these  character s are adde d then"RTN ","PXKFVST ",9,0) ;     the data  in this f ield can b e either a dded or ed ited."RTN" ,"PXKFVST" ,10,0) ; 2 . If only  the ~ is a dded then  the data i n this fie ld can be" RTN","PXKF VST",11,0)  ;    neit her added  or edited. "RTN","PXK FVST",12,0 ) ; 3. IF  only the ~ A is added  then the  data can o nly be add ed to"RTN" ,"PXKFVST" ,13,0) ;     the file  for this  field but  not edited ."RTN","PX KFVST",14, 0) ; 4. If  only the  ~E is adde d the data  can only  be edited  in"RTN","P XKFVST",15 ,0) ;    t his file f or this fi eld. (not  a likely p ossibility )"RTN","PX KFVST",16, 0) ;"RTN", "PXKFVST", 17,0) ; Th e word "OP TION" in f ront of th e line of  text below  tells the  "RTN","PX KFVST",18, 0) ;softwa re to dete rmine,base d on the d ata, the a ppropriate ness"RTN", "PXKFVST", 19,0) ;of  using eith er a "///"  or "////"  stuff in  a DIE call ."RTN","PX KFVST",20, 0) ;"RTN", "PXKFVST", 21,0) ; Th e informat ion on lin e tag 0 $P (,," * ",1 ) are the  piece numb ers"RTN"," PXKFVST",2 2,0) ;of t he fields  on the zer o node tha t are requ ired by th e data"RTN ","PXKFVST ",23,0) ;d ictionary  and are ch ecked for  to determi ne if enou gh data is  present"R TN","PXKFV ST",24,0)  ;to procee d without  any errors . $P(,," *  ",2) are  the nodes  and"RTN"," PXKFVST",2 5,0) ;piec e numbers  of the fie lds used t o determin e duplicat es in the" RTN","PXKF VST",26,0)  ;file (no de+piece ( eg. 12+4)) . $P(,," *  ",3) is a  flag use  to"RTN","P XKFVST",27 ,0) ;deter mine if du plicates a re allowed  in this v isit file.  "RTN","PX KFVST",28, 0) ;If it  is set to  0 then no  duplicate  checks wil l occur. I f it is"RT N","PXKFVS T",29,0) ; set to 1 t hen the fi le will be  checked f or duplica tes based  on"RTN","P XKFVST",30 ,0) ;the i nformation  in $P 2." RTN","PXKF VST",31,0)  ;"RTN","P XKFVST",32 ,0) ; The  following  is the fil e's global  name.  Ea ch global  must have  a"RTN","PX KFVST",33, 0) ;unique  name and  can not ha ve any sub scripts as  part of t he global  root."RTN" ,"PXKFVST" ,34,0)GLOB AL ;;^AUPN VSIT"RTN", "PXKFVST", 35,0) ;"RT N","PXKFVS T",36,0)EN 1 ;"RTN"," PXKFVST",3 7,0) S PXK ER="""RTN" ,"PXKFVST" ,38,0) S P XKER=$P($T (@PXKNOD+P XKPCE),";; ",2) Q"RTN ","PXKFVST ",39,0)EN2  ;"RTN","P XKFVST",40 ,0) S PXKF D="""RTN", "PXKFVST", 41,0) S PX KFD=$P($T( @PXKNOD+PX KPCE),";;" ,2) D"RTN" ,"PXKFVST" ,42,0) .I  PXKFD="" S  PXKPCE=PX KPCE+1 D E N2"RTN","P XKFVST",43 ,0) Q"RTN" ,"PXKFVST" ,44,0)ADD  ;Add an en try to the  file"RTN" ,"PXKFVST" ,45,0) Q"R TN","PXKFV ST",46,0)0  ;;1,3,5,7 ,8,22 *  *  0"RTN","P XKFVST",47 ,0) ;;.01/ //^S X=$G( ~"RTN","PX KFVST",48, 0) ;;.02// /^S X=$G(~ "RTN","PXK FVST",49,0 ) ;;.03/// ^S X=$G(~" RTN","PXKF VST",50,0)  ;;"RTN"," PXKFVST",5 1,0) ;;.05 ////^S X=$ G(~"RTN"," PXKFVST",5 2,0) ;;.06 ////^S X=$ G(~"RTN"," PXKFVST",5 3,0) ;;.07 ///^S X=$G (~"RTN","P XKFVST",54 ,0) ;;.08/ ///^S X=$G (~"RTN","P XKFVST",55 ,0) ;;.09/ //^S X=$G( ~"RTN","PX KFVST",56, 0) ;;"RTN" ,"PXKFVST" ,57,0) ;;. 11///^S X= $G(~"RTN", "PXKFVST", 58,0) ;;.1 2////^S X= $G(~"RTN", "PXKFVST", 59,0) ;;.1 3///^S X=$ G(~"RTN"," PXKFVST",6 0,0) ;;"RT N","PXKFVS T",61,0) ; ;"RTN","PX KFVST",62, 0) ;;"RTN" ,"PXKFVST" ,63,0) ;;" RTN","PXKF VST",64,0)  ;;.18///^ S X=$G(~"R TN","PXKFV ST",65,0)  ;;"RTN","P XKFVST",66 ,0) ;;"RTN ","PXKFVST ",67,0) ;; .21////^S  X=$G(~"RTN ","PXKFVST ",68,0) ;; .22////^S  X=$G(~"RTN ","PXKFVST ",69,0) ;; .23////^S  X=$G(~"RTN ","PXKFVST ",70,0) ;; .24////^S  X=$G(~"RTN ","PXKFVST ",71,0) ;; "RTN","PXK FVST",72,0 ) ;;.26/// /^S X=$G(~ "RTN","PXK FVST",73,0 )21 ;;"RTN ","PXKFVST ",74,0) ;; 2101///^S  X=$G(~"RTN ","PXKFVST ",75,0)800  ;;"RTN"," PXKFVST",7 6,0) ;;800 01///^S X= $G(~"RTN", "PXKFVST", 77,0) ;;80 002///^S X =$G(~"RTN" ,"PXKFVST" ,78,0) ;;8 0003///^S  X=$G(~"RTN ","PXKFVST ",79,0) ;; 80004///^S  X=$G(~"RT N","PXKFVS T",80,0) ; ;80005///^ S X=$G(~ ; added 6/17 /98 for MS T enhancem ent"RTN"," PXKFVST",8 1,0) ;;800 06///^S X= $G(~ ;PX*1 *111 - add ed for HNC  enhanceme nt"RTN","P XKFVST",82 ,0) ;;8000 7///^S X=$ G(~ ;PX*1* 130"RTN"," PXKFVST",8 3,0) ;;800 08///^S X= $G(~ ;PX*1 *168"RTN", "PXKFVST", 84,0) ;;80 009///^S X =$G(~ ; dj s  PX*1.0* 207  RSD S PEC #2.6.2 .1.1  Adde d for Camp  Lejeune e nhancement "RTN","PXK FVST",85,0 )812 ;;"RT N","PXKFVS T",86,0) ; ;81201///^ S X=$G("RT N","PXKFVS T",87,0) ; ;81202//// ^S X=$G("R TN","PXKFV ST",88,0)  ;;81203/// /^S X=$G(" RTN","PXKF VST",89,0)  ;"RTN","P XKFVST",90 ,0)UPD ;Up  date visi t file usi ng visit t racking"RT N","PXKFVS T",91,0) ; --new VSIT  to make s ure that n one are le ft around  after call "RTN","PXK FVST",92,0 ) N PXTMPV ST"RTN","P XKFVST",93 ,0) S PXTM PVST=VSIT( "IEN")"RTN ","PXKFVST ",94,0) N  VSIT"RTN", "PXKFVST", 95,0) S VS IT("IEN")= PXTMPVST"R TN","PXKFV ST",96,0)  I $G(PXKAV (0,8))]""  D"RTN","PX KFVST",97, 0) .I PXKA V(0,8)="@"  S VSIT("D SS")="@""R TN","PXKFV ST",98,0)  .E  D"RTN" ,"PXKFVST" ,99,0) ..K  ^UTILITY( "DIQ1",$J) "RTN","PXK FVST",100, 0) ..S DIC =40.7,DA=+ $G(PXKAV(0 ,8)),DIQ(0 )="I",DR=1  D EN^DIQ1 "RTN","PXK FVST",101, 0) ..S VSI T("DSS")=$ G(^UTILITY ("DIQ1",$J ,40.7,DA,1 ,"I"))"RTN ","PXKFVST ",102,0) K  ^UTILITY( "DIQ1",$J) ,DIQ,DR,DA ,DIC"RTN", "PXKFVST", 103,0) I $ G(PXKAV(0, 6))]"" S V SIT("INS") =$G(PXKAV( 0,6))"RTN" ,"PXKFVST" ,104,0) I  $G(PXKAV(0 ,18))]"" S  VSIT("COD ")=$G(PXKA V(0,18))"R TN","PXKFV ST",105,0)  ;--cannot  edit "ELG ""RTN","PX KFVST",106 ,0) I $G(P XKAV(0,22) )]"" S VSI T("LOC")=$ G(PXKAV(0, 22))"RTN", "PXKFVST", 107,0) I $ G(PXKAV(0, 26))]"" S  VSIT("ACT" )=$G(PXKAV (0,26)) ;P X*1.0*164  Set Patien t Account  Number ref erence"RTN ","PXKFVST ",108,0) ; Classifica tion quest ions"RTN", "PXKFVST", 109,0) N P XP,PXV,PXN "RTN","PXK FVST",110, 0) ;AO, IR , EC and C LV not app licable if  SC answer ed YES (1) "RTN","PXK FVST",111, 0) ;I $G(P XKAV(800,1 ))=1 F PXP =2:1:4,9 S  PXKAV(800 ,PXP)="@"" RTN","PXKF VST",112,0 ) ;  djs   PX*1.0*207   RSD SPEC  #2.6.2.1. 1  Increas e FOR loop  for Camp  Lejeune"RT N","PXKFVS T",113,0)  F PXP=1:1: 9 D"RTN"," PXKFVST",1 14,0) .S P XV=$G(PXKA V(800,PXP) )"RTN","PX KFVST",115 ,0) .;  dj s  PX*1.0* 207  RSD S PEC #2.6.2 .1.1 Added  Camp Leje une indica tor to str ing of env ironmental  indicator s"RTN","PX KFVST",116 ,0) .S PXN =$P("SC^AO ^IR^EC^MST ^HNC^CV^SH AD^CLV","^ ",PXP)"RTN ","PXKFVST ",117,0) . I PXV'=""  S VSIT(PXN )=PXV"RTN" ,"PXKFVST" ,118,0) D  UPD^VSIT"R TN","PXKFV ST",119,0)  K VSIT("D SS"),VSIT( "COD"),VSI T("SC"),VS IT("AO"),V SIT("IR"), VSIT("EC") "RTN","PXK FVST",120, 0) K VSIT( "LOC"),VSI T("INS"),V SIT("ELG") ,VSIT("MDT ")"RTN","P XKFVST",12 1,0) ;PX*1 *111 - add ed for HNC  enhanceme nt"RTN","P XKFVST",12 2,0) ;  dj s  PX*1.0* 207  RSD S PEC #2.6.2 .1.1  Kill  Camp Leje une array  item"RTN", "PXKFVST", 123,0) K V SIT("MST") ,VSIT("HNC "),VSIT("C V"),VSIT(" SHAD"),VSI T("CLV")"R TN","PXKFV ST",124,0)  Q"RTN","P XKFVST",12 5,0)SPEC ; "RTN","PXK FVST",126, 0) Q"RTN", "PXKVST")0 ^24^B20117 091"RTN"," PXKVST",1, 0)PXKVST ; ISL/ARS -  SET UP VIS IT FIELDS  BEFORE CAL LING OFF T O VSIT ;8/ 1/96"RTN", "PXKVST",2 ,0) ;;1.0; PCE PATIEN T CARE ENC OUNTER;**5 6,111,130, 164,168,20 7**;Aug 12 , 1996;Bui ld 54"RTN" ,"PXKVST", 3,0)VSIT ; ENTRY POIN T "RTN","P XKVST",4,0 ) ;COMMON  SECTION"RT N","PXKVST ",5,0) N P XKAFTR,PXK AFT8,PXKAF T15,PXKAFT 21,PXKAF81 1,PXKAF812 ,PXVSTIEN" RTN","PXKV ST",6,0) N  VSIT,VSIT PKG"RTN"," PXKVST",7, 0) S PXKAF TR=$S($G(^ TMP("PXK", $J,"VST",1 ,0,"AFTER" ))]"":^TMP ("PXK",$J, "VST",1,0, "AFTER"),1 :"")"RTN", "PXKVST",8 ,0) Q:PXKA FTR="""RTN ","PXKVST" ,9,0) S PX KAFT21=$S( $G(^TMP("P XK",$J,"VS T",1,21,"A FTER"))]"" :^TMP("PXK ",$J,"VST" ,1,21,"AFT ER"),1:"") "RTN","PXK VST",10,0)  S PXKAFT1 5=$S($G(^T MP("PXK",$ J,"VST",1, 150,"AFTER "))]"":^TM P("PXK",$J ,"VST",1,1 50,"AFTER" ),1:"")"RT N","PXKVST ",11,0) S  PXKAFT8=$S ($G(^TMP(" PXK",$J,"V ST",1,800, "AFTER"))] "":^TMP("P XK",$J,"VS T",1,800," AFTER"),1: "")"RTN"," PXKVST",12 ,0) S PXKA F811=$S($G (^TMP("PXK ",$J,"VST" ,1,811,"AF TER"))]"": ^TMP("PXK" ,$J,"VST", 1,811,"AFT ER"),1:"") "RTN","PXK VST",13,0)  S PXKAF81 2=$S($G(^T MP("PXK",$ J,"VST",1, 812,"AFTER "))]"":^TM P("PXK",$J ,"VST",1,8 12,"AFTER" ),1:"")"RT N","PXKVST ",14,0) S  VSIT("IEN" )=$S(^TMP( "PXK",$J," VST",1,"IE N")]"":^TM P("PXK",$J ,"VST",1," IEN"),1:"" )"RTN","PX KVST",15,0 ) I VSIT(" IEN")="" S  PXKAFTR=$ TR(PXKAFTR ,"@"),PXKA FT8=$TR(PX KAFT8,"@") "RTN","PXK VST",16,0)  S VSIT("V DT")=$S($P (PXKAFTR," ^",1)]"":$ P(PXKAFTR, "^",1),1:" NOW")"RTN" ,"PXKVST", 17,0) S VS IT("TYP")= $P(PXKAFTR ,"^",3)"RT N","PXKVST ",18,0) S  VSIT("INS" )=$P(PXKAF TR,"^",6)" RTN","PXKV ST",19,0)  S VSIT("OU T")=$P(PXK AFT21,"^") "RTN","PXK VST",20,0)  S VSIT("P AT")=$P(PX KAFTR,"^", 5)"RTN","P XKVST",21, 0) S VSIT( "SVC")=$P( PXKAFTR,"^ ",7)"RTN", "PXKVST",2 2,0) S VSI T("DSS")=$ P(PXKAFTR, "^",8)"RTN ","PXKVST" ,23,0) S V SIT("LNK") =$P(PXKAFT R,"^",12)" RTN","PXKV ST",24,0)  S VSIT("WI A")=$P(PXK AFTR,"^",1 6)"RTN","P XKVST",25, 0) S VSIT( "LOS")=$P( PXKAFTR,"^ ",17)"RTN" ,"PXKVST", 26,0) S VS IT("COD")= $P(PXKAFTR ,"^",18)"R TN","PXKVS T",27,0) S :$P(PXKAFT R,"^",21)] "" VSIT("E LG")=$P(PX KAFTR,"^", 21)"RTN"," PXKVST",28 ,0) S VSIT ("LOC")=$P (PXKAFTR," ^",22)"RTN ","PXKVST" ,29,0) S V SIT("ACT") =$P(PXKAFT R,"^",26)  ;PX*1.0*16 4"RTN","PX KVST",30,0 ) S:$P(PXK AFT8,"^",1 )]"" VSIT( "SC")=$P(P XKAFT8,"^" ,1)"RTN"," PXKVST",31 ,0) S:$P(P XKAFT8,"^" ,2)]"" VSI T("AO")=$P (PXKAFT8," ^",2)"RTN" ,"PXKVST", 32,0) S:$P (PXKAFT8," ^",3)]"" V SIT("IR")= $P(PXKAFT8 ,"^",3)"RT N","PXKVST ",33,0) S: $P(PXKAFT8 ,"^",4)]""  VSIT("EC" )=$P(PXKAF T8,"^",4)" RTN","PXKV ST",34,0)  S:$P(PXKAF T8,"^",5)] "" VSIT("M ST")=$P(PX KAFT8,"^", 5) ;added  6/17/98 fo r MST enha ncement"RT N","PXKVST ",35,0) ;P X*1*111 -  added for  HNC enhanc ement"RTN" ,"PXKVST", 36,0) S:$P (PXKAFT8," ^",6)]"" V SIT("HNC") =$P(PXKAFT 8,"^",6)"R TN","PXKVS T",37,0) S :$P(PXKAFT 8,"^",7)]" " VSIT("CV ")=$P(PXKA FT8,"^",7) "RTN","PXK VST",38,0)  S:$P(PXKA FT8,"^",8) ]"" VSIT(" SHAD")=$P( PXKAFT8,"^ ",8)"RTN", "PXKVST",3 9,0) ;  dj s  PX*1.0* 207  RSD S PEC #2.6.2 .4.1.1  Se t VSIT arr ay Camp Le jeune #9 t o PXKAFT8  piece #9 i f null"RTN ","PXKVST" ,40,0) S:$ P(PXKAFT8, "^",9)]""  VSIT("CLV" )=$P(PXKAF T8,"^",9)" RTN","PXKV ST",41,0)  S:$P(PXKAF T15,"^",1) ]"" VSIT(" SVP")=$P(P XKAFT15,"^ ",1)"RTN", "PXKVST",4 2,0) S:$P( PXKAFT15," ^",2)]"" V SIT("IO")= $P(PXKAFT1 5,"^",2)"R TN","PXKVS T",43,0) S :$P(PXKAFT 15,"^",3)] "" VSIT("P RI")=$P(PX KAFT15,"^" ,3)"RTN"," PXKVST",44 ,0) S:$P(P XKAF812,"^ ",2)]"" VS IT("PKG")= $P(PXKAF81 2,"^",2)"R TN","PXKVS T",45,0) S :$P(PXKAF8 12,"^",3)] "" VSIT("S OR")=$P(PX KAF812,"^" ,3)"RTN"," PXKVST",46 ,0) S:PXKA F811]"" VS IT("COM")= PXKAF811"R TN","PXKVS T",47,0) I  $G(VSIT(" PRI"))="", VSIT("SVC" )="E"!($P( $G(^SC(+VS IT("LOC"), 0)),"^",7) =VSIT("DSS ")) S VSIT ("PRI")="P ""RTN","PX KVST",48,0 ) S VSITPK G="PX""RTN ","PXKVST" ,49,0) I ' $D(VSIT(0) ) D"RTN"," PXKVST",50 ,0) .S VSI T(0)=$S(VS IT("SVC")= "E":"D0NM" ,1:"D0NEM" )"RTN","PX KVST",51,0 ) ;"RTN"," PXKVST",52 ,0) ;CALL  FOR VSIT"R TN","PXKVS T",53,0) D  ^VSIT"RTN ","PXKVST" ,54,0) I ' $D(VSIT("I EN"))#2 Q" RTN","PXKV ST",55,0)  S PXVSTIEN =$P(VSIT(" IEN"),"^", 1)"RTN","P XKVST",56, 0) S ^TMP( "PXK",$J," VST",1,"IE N")=PXVSTI EN"RTN","P XKVST",57, 0) I PXVST IEN<1 Q"RT N","PXKVST ",58,0) D  VIEN(PXVST IEN)"RTN", "PXKVST",5 9,0) I $P( VSIT("IEN" ),"^",3)'= 1 D"RTN"," PXKVST",60 ,0) .S ^TM P("PXK",$J ,"VST",1,0 ,"BEFORE") =^AUPNVSIT (PXVSTIEN, 0)"RTN","P XKVST",61, 0) .S ^TMP ("PXK",$J, "VST",1,21 ,"BEFORE") =$G(^AUPNV SIT(PXVSTI EN,21))"RT N","PXKVST ",62,0) .S  ^TMP("PXK ",$J,"VST" ,1,150,"BE FORE")=$G( ^AUPNVSIT( PXVSTIEN,1 50))"RTN", "PXKVST",6 3,0) .S ^T MP("PXK",$ J,"VST",1, 800,"BEFOR E")=$G(^AU PNVSIT(PXV STIEN,800) )"RTN","PX KVST",64,0 ) .S ^TMP( "PXK",$J," VST",1,811 ,"BEFORE") =$G(^AUPNV SIT(PXVSTI EN,811))"R TN","PXKVS T",65,0) . S ^TMP("PX K",$J,"VST ",1,812,"B EFORE")=$G (^AUPNVSIT (PXVSTIEN, 812))"RTN" ,"PXKVST", 66,0) .S $ P(^TMP("PX K",$J,"VST ",1,0,"AFT ER"),"^",3 )=$P(^AUPN VSIT(PXVST IEN,0),"^" ,3)"RTN"," PXKVST",67 ,0) .S $P( ^TMP("PXK" ,$J,"VST", 1,0,"AFTER "),"^",7)= $P(^AUPNVS IT(PXVSTIE N,0),"^",7 )"RTN","PX KVST",68,0 ) I $P(VSI T("IEN")," ^",3)=1 D" RTN","PXKV ST",69,0)  .S ^TMP("P XK",$J,"VS T",1,0,"AF TER")=^AUP NVSIT(PXVS TIEN,0)"RT N","PXKVST ",70,0) .S  ^TMP("PXK ",$J,"VST" ,1,21,"AFT ER")=$G(^A UPNVSIT(PX VSTIEN,21) )"RTN","PX KVST",71,0 ) .S ^TMP( "PXK",$J," VST",1,150 ,"AFTER")= $G(^AUPNVS IT(PXVSTIE N,150))"RT N","PXKVST ",72,0) .S  ^TMP("PXK ",$J,"VST" ,1,800,"AF TER")=$G(^ AUPNVSIT(P XVSTIEN,80 0))"RTN"," PXKVST",73 ,0) .S ^TM P("PXK",$J ,"VST",1,8 11,"AFTER" )=$G(^AUPN VSIT(PXVST IEN,811))" RTN","PXKV ST",74,0)  .S ^TMP("P XK",$J,"VS T",1,812," AFTER")=$G (^AUPNVSIT (PXVSTIEN, 812))"RTN" ,"PXKVST", 75,0) .S ^ TMP("PXK", $J,"VST",1 ,0,"BEFORE ")="""RTN" ,"PXKVST", 76,0) .S ^ TMP("PXK", $J,"VST",1 ,21,"BEFOR E")="""RTN ","PXKVST" ,77,0) .S  ^TMP("PXK" ,$J,"VST", 1,150,"BEF ORE")="""R TN","PXKVS T",78,0) . S ^TMP("PX K",$J,"VST ",1,800,"B EFORE")="" "RTN","PXK VST",79,0)  .S ^TMP(" PXK",$J,"V ST",1,811, "BEFORE")= """RTN","P XKVST",80, 0) .S ^TMP ("PXK",$J, "VST",1,81 2,"BEFORE" )="""RTN", "PXKVST",8 1,0) .I $D (PXELAP)#2  D"RTN","P XKVST",82, 0) ..S ^TM P("PXKCO", $J,PXVSTIE N,"VST",PX VSTIEN,"EL AP","BEFOR E")="""RTN ","PXKVST" ,83,0) ..S  ^TMP("PXK CO",$J,PXV STIEN,"VST ",PXVSTIEN ,"ELAP","A FTER")=PXE LAP"RTN"," PXKVST",84 ,0) K VSIT "RTN","PXK VST",85,0)  Q"RTN","P XKVST",86, 0) ;"RTN", "PXKVST",8 7,0)VIEN(V IEN) ;Put  the Visit  IEN in the  AFTERs fo r all of t he V-Files "RTN","PXK VST",88,0)  N PXCAINX 1,PXCAINX2 "RTN","PXK VST",89,0)  S PXCAINX 1="""RTN", "PXKVST",9 0,0) F  S  PXCAINX1=$ O(^TMP("PX K",$J,PXCA INX1)) Q:P XCAINX1']" "  D:"^VST ^SOR^"'[PX CAINX1"RTN ","PXKVST" ,91,0) . S  PXCAINX2= """RTN","P XKVST",92, 0) . F  S  PXCAINX2=$ O(^TMP("PX K",$J,PXCA INX1,PXCAI NX2)) Q:PX CAINX2']""   D"RTN"," PXKVST",93 ,0) .. I $ D(^TMP("PX K",$J,PXCA INX1,PXCAI NX2,0,"AFT ER"))=1 S  $P(^TMP("P XK",$J,PXC AINX1,PXCA INX2,0,"AF TER"),"^", 3)=VIEN"RT N","PXKVST ",94,0) Q" RTN","PXKV ST",95,0)  ;"RTN","PX RPC")0^26^ B169336970 "RTN","PXR PC",1,0)PX RPC ;ISL/J LC - PCE D ATA2PCE RP C ;06/23/2 016"RTN"," PXRPC",2,0 ) ;;1.0;PC E PATIENT  CARE ENCOU NTER;**200 ,209,210,2 15,216,207 **;Aug 12,  1996;Buil d 54"RTN", "PXRPC",3, 0) ;"RTN", "PXRPC",4, 0) ; Refer ence to UC UMDATA^LEX MUCUM supp orted by I CR #6225"R TN","PXRPC ",5,0) ; R eference t o ICDDX^IC DEX suppor ted by ICR  #5747"RTN ","PXRPC", 6,0) ;"RTN ","PXRPC", 7,0) ;"RTN ","PXRPC", 8,0)SAVE(O K,PCELIST, LOC,PKGNAM E,SRC) ; s ave PCE in formation" RTN","PXRP C",9,0) N  VSTR"RTN", "PXRPC",10 ,0) N PXAP I,PXDEL,PK G,PROBLEMS ,PXAVST,PX ERROR,PXAP REDT"RTN", "PXRPC",11 ,0) I '$D( PCELIST(1) ) S OK=-3  Q"RTN","PX RPC",12,0)  S VSTR=$P (PCELIST(1 ),U,4) K ^ TMP("PXRPC ",$J,VSTR) "RTN","PXR PC",13,0)  I $G(PKGNA ME)="" S O K=-3 Q"RTN ","PXRPC", 14,0) I $G (SRC)="" S  OK=-3 Q"R TN","PXRPC ",15,0) S  PKG=$$PKG2 IEN^VSIT(P KGNAME) I  PKG=-1 S O K=-3 Q"RTN ","PXRPC", 16,0) M ^T MP("PXRPC" ,$J,VSTR)= PCELIST"RT N","PXRPC" ,17,0) D D QSAVE(.PCE LIST,"PXAP I","PXDEL" ,.PROBLEMS ,.SRC)"RTN ","PXRPC", 18,0) I '$ D(PXAPI)#1 0 S OK=-3  Q"RTN","PX RPC",19,0)  I $D(PXAP I("PROVIDE R")) S PXA PREDT=1 ;A llow edit  of primary  flag"RTN" ,"PXRPC",2 0,0) D DAT A2PCE(.OK, "PXAPI",PK G,SRC,.PXA VST,.PXERR OR)"RTN"," PXRPC",21, 0) Q"RTN", "PXRPC",22 ,0) ;"RTN" ,"PXRPC",2 3,0)DQSAVE (PCELIST,P XPCEARR,PX PCEDARR,PR OBLEMS,SRC ) ;"RTN"," PXRPC",24, 0) ;"RTN", "PXRPC",25 ,0) ; Proc esses PCEL IST input  array and  creates a  new array  in a forma t"RTN","PX RPC",26,0)  ; that ca n be passe d into DAT A2PCE^PXAP I."RTN","P XRPC",27,0 ) ;"RTN"," PXRPC",28, 0) ;Input: "RTN","PXR PC",29,0)  ;   .PCELI ST - (Requ ired) Arra y passed b y referenc e."RTN","P XRPC",30,0 ) ;               Thi s should b e in the s ame format  as the PX  SAVE DATA "RTN","PXR PC",31,0)  ;               and O RWPCE SAVE  RPCs' PCE LIST input  parameter ."RTN","PX RPC",32,0)  ;   PXPCE ARR - (Req uired) The  root of a n array pa ssed as a  String val ue"RTN","P XRPC",33,0 ) ;               (e. g., "ORPXA PI") that  this API w ill popula te based o ff"RTN","P XRPC",34,0 ) ;               the  PCELIST a rgument. T his array  will be in  a format" RTN","PXRP C",35,0) ;                that c an be pass ed into DA TA2PCE^PXA PI."RTN"," PXRPC",36, 0) ;  PXPC EDARR - (R equired) T he root of  an array  passed as  a String v alue"RTN", "PXRPC",37 ,0) ;               ( e.g., "ORP XDEL") tha t this API  will popu late based  off"RTN", "PXRPC",38 ,0) ;               t he PCELIST  argument.  This arra y will be  populated  with"RTN", "PXRPC",39 ,0) ;               s ome deleti ons that n eed to be  filed to D ATA2PCE be fore"RTN", "PXRPC",40 ,0) ;               f iling PXPC EARR. This  array wil l be in a  format"RTN ","PXRPC", 41,0) ;                that can  be passed  into DATA2 PCE^PXAPI. "RTN","PXR PC",42,0)  ;  .PROBLE MS - (Requ ired) This  API will  populate t his array  with POV"R TN","PXRPC ",43,0) ;                entries  that are  marked to  be added t o the Prob lem List." RTN","PXRP C",44,0) ;        .SR C - (Requi red) The s ource of t he data -  such as 'T EXT"RTN"," PXRPC",45, 0) ;               IN TEGRATION  UTILITIES' . This API  can possi bly change  the"RTN", "PXRPC",46 ,0) ;               v alue of SR C, dependi ng on the  Health Fac tor (HF) v alues"RTN" ,"PXRPC",4 7,0) ;                contained  in PCELIST ."RTN","PX RPC",48,0)  ;"RTN","P XRPC",49,0 ) N TYP,CO DE,IEN,I,X "RTN","PXR PC",50,0)  N CAT,NARR ,ROOT,ROOT 2,PXENCDT, IMPLDT"RTN ","PXRPC", 51,0) N PR V,CPT,ICD, IMM,SK,PED ,HF,XAM,TR T,ICR,MOD, MODCNT,MOD IDX,MODS"R TN","PXRPC ",52,0) N  COM,COMMEN T,COMMENTS ,SVCAT"RTN ","PXRPC", 53,0) N DF N,PXAPREDT ,PXCPTDEL" RTN","PXRP C",54,0) ;  Vars for  Info Sourc e (IMMIS)  Imm. Admin  Route (IM MRT), Body  Site (IMM AL), Lot,  Manufactur er, Exp. D ate & Comm ents"RTN", "PXRPC",55 ,0) N IMMI SNM,IMMISI EN,IMMRTNM ,IMMRTIEN, IMMRTERR,I MMALNAME,I MMALIEN,IM MALERR,IMM LOT,IMMMAN UF,IMMEXPD T,IMMCOMM, IMMCOMMS,I MMLOTIEN"R TN","PXRPC ",56,0) N  NUM,REMARK ,SEQ,IMMDS G,IMMCVX,I MMCVXER,IM MOVERRIDE, SKRDCOM"RT N","PXRPC" ,57,0) S I MPLDT=$$IM PDATE^LEXU ("10D")"RT N","PXRPC" ,58,0) S ( PRV,CPT,IC D,IMM,SK,P ED,HF,XAM, TRT,ICR)=0 "RTN","PXR PC",59,0)  S I="" F   S I=$O(PCE LIST(I)) Q :'I  S X=P CELIST(I)  D"RTN","PX RPC",60,0)  . S X=PCE LIST(I),TY P=$P(X,U), CODE=$P(X, U,2),CAT=$ P(X,U,3),N ARR=$P(X,U ,4)"RTN"," PXRPC",61, 0) . I $E( TYP,1,3)=" PRV" D  Q" RTN","PXRP C",62,0) .  . Q:'$L(C ODE)"RTN", "PXRPC",63 ,0) . . S  PRV=PRV+1" RTN","PXRP C",64,0) .  . S ROOT= PXPCEARR_" (""PROVIDE R"","_PRV_ ")""RTN"," PXRPC",65, 0) . . S R OOT2=PXPCE DARR_"(""P ROVIDER"", "_PRV_")"" RTN","PXRP C",66,0) .  . I $E(TY P,4)'="-"  D"RTN","PX RPC",67,0)  . . . S @ ROOT@("NAM E")=CODE"R TN","PXRPC ",68,0) .  . . S @ROO T@("PRIMAR Y")=$P(X,U ,6)"RTN"," PXRPC",69, 0) . . S @ ROOT2@("NA ME")=CODE" RTN","PXRP C",70,0) .  . S @ROOT 2@("DELETE ")=1"RTN", "PXRPC",71 ,0) . . S  PXAPREDT=1  ;Allow ed it of prim ary flag"R TN","PXRPC ",72,0) .  I TYP="VST " D  Q"RTN ","PXRPC", 73,0) . .  S ROOT=PXP CEARR_"("" ENCOUNTER" ",1)""RTN" ,"PXRPC",7 4,0) . . I  CODE="DT"  S (PXENCD T,@ROOT@(" ENC D/T")) =$P(X,U,3)  Q"RTN","P XRPC",75,0 ) . . I CO DE="PT" S  @ROOT@("PA TIENT")=$P (X,U,3),DF N=$P(X,U,3 ) Q"RTN"," PXRPC",76, 0) . . I C ODE="HL" S  @ROOT@("H OS LOC")=$ P(X,U,3) Q "RTN","PXR PC",77,0)  . . I CODE ="PR" S @R OOT@("PARE NT")=$P(X, U,3) Q"RTN ","PXRPC", 78,0) . .  ;prevents  checkout!" RTN","PXRP C",79,0) .  . I CODE= "VC" S (SV CAT,@ROOT@ ("SERVICE  CATEGORY") )=$P(X,U,3 ) Q"RTN"," PXRPC",80, 0) . . I C ODE="SC" S  @ROOT@("S C")=$P(X,U ,3) Q"RTN" ,"PXRPC",8 1,0) . . I  CODE="AO"  S @ROOT@( "AO")=$P(X ,U,3) Q"RT N","PXRPC" ,82,0) . .  I CODE="I R" S @ROOT @("IR")=$P (X,U,3) Q" RTN","PXRP C",83,0) .  . I CODE= "EC" S @RO OT@("EC")= $P(X,U,3)  Q"RTN","PX RPC",84,0)  . . I COD E="MST" S  @ROOT@("MS T")=$P(X,U ,3) Q"RTN" ,"PXRPC",8 5,0) . . I  CODE="HNC " S @ROOT@ ("HNC")=$P (X,U,3) Q" RTN","PXRP C",86,0) .  . I CODE= "CV" S @RO OT@("CV")= $P(X,U,3)  Q"RTN","PX RPC",87,0)  . . I COD E="SHD" S  @ROOT@("SH AD")=$P(X, U,3) Q"RTN ","PXRPC", 88,0) . .  ; djs PX*1 .0*207 RSD  SPEC # Ad d Camp Lej eune to en v. ind. pr ocessing"R TN","PXRPC ",89,0) .  . I CODE=" CLV" S @RO OT@("CLV") =$P(X,U,3)  Q"RTN","P XRPC",90,0 ) . . I CO DE="OL" D   Q"RTN","P XRPC",91,0 ) . . . I  +$P(X,U,3)  S @ROOT@( "INSTITUTI ON")=$P(X, U,3)"RTN", "PXRPC",92 ,0) . . .  E  I $P(X, U,4)'="",$ P(X,U,4)'= "0" D"RTN" ,"PXRPC",9 3,0) . . .  . I $$PAT CH^XPDUTL( "PX*1.0*96 ") S @ROOT @("OUTSIDE  LOCATION" )=$P(X,U,4 )"RTN","PX RPC",94,0)  . . . . E   S @ROOT@ ("COMMENT" )="OUTSIDE  LOCATION:   "_$P(X,U ,4)"RTN"," PXRPC",95, 0) . I $E( TYP,1,3)=" CPT" D  Q" RTN","PXRP C",96,0) .  . Q:'$L(C ODE)"RTN", "PXRPC",97 ,0) . . S  CPT=CPT+1, ROOT=PXPCE ARR_"(""PR OCEDURE"", "_CPT_")"" RTN","PXRP C",98,0) .  . S IEN=$ $CODEN^ICP TCOD(CODE)  ;ICR #199 5"RTN","PX RPC",99,0)  . . S @RO OT@("PROCE DURE")=IEN "RTN","PXR PC",100,0)  . . I +$P (X,U,9) D" RTN","PXRP C",101,0)  . . . S MO DS=$P(X,U, 9),MODCNT= +MODS"RTN" ,"PXRPC",1 02,0) . .  . F MODIDX =1:1:MODCN T D"RTN"," PXRPC",103 ,0) . . .  . S MOD=$P ($P(MODS," ;",MODIDX+ 1),"/")"RT N","PXRPC" ,104,0) .  . . . S @R OOT@("MODI FIERS",MOD )="""RTN", "PXRPC",10 5,0) . . S :$L(CAT) @ ROOT@("CAT EGORY")=CA T"RTN","PX RPC",106,0 ) . . S:$L (NARR) @RO OT@("NARRA TIVE")=NAR R"RTN","PX RPC",107,0 ) . . S:$L ($P(X,U,5) ) @ROOT@(" QTY")=$P(X ,U,5)"RTN" ,"PXRPC",1 08,0) . .  S:$P(X,U,6 )>0 @ROOT@ ("ENC PROV IDER")=$P( X,U,6)"RTN ","PXRPC", 109,0) . .  S:$L($P(X ,U,10))>0  COMMENT($P (X,U,10))= "PROCEDURE ^"_CPT"RTN ","PXRPC", 110,0) . .  I $E(TYP, 4)="-" S @ ROOT@("DEL ETE")=1,@R OOT@("QTY" )=0,PXCPTD EL=CPT"RTN ","PXRPC", 111,0) . I  $E(TYP,1, 3)="POV" D   Q"RTN"," PXRPC",112 ,0) . . N  PXDXI,PXDX "RTN","PXR PC",113,0)  . . Q:'$L (CODE)"RTN ","PXRPC", 114,0) . .  F PXDXI=1 :1:$L(CODE ,"/") D"RT N","PXRPC" ,115,0) .  . . N CSYS ,CDT,IEN,L EXIEN"RTN" ,"PXRPC",1 16,0) . .  . S PXDX=$ P(CODE,"/" ,PXDXI)"RT N","PXRPC" ,117,0) .  . . S ICD= ICD+1,ROOT =PXPCEARR_ "(""DX/PL" ","_ICD_") ""RTN","PX RPC",118,0 ) . . . S  CDT=$S($G( SVCAT)="E" :DT,1:$G(P XENCDT))"R TN","PXRPC ",119,0) .  . . S CSY S=$S(CDT'< IMPLDT:"10 D",1:"ICD" )"RTN","PX RPC",120,0 ) . . . I  (PXDX]""), (PXDX'["." ) S PXDX=P XDX_".""RT N","PXRPC" ,121,0) .  . . S IEN= +$$ICDDX^I CDEX(PXDX, CDT,$S(CSY S="10D":30 ,1:1),"E")  ; ICR #57 47"RTN","P XRPC",122, 0) . . . I  IEN'>0 Q" RTN","PXRP C",123,0)  . . . S @R OOT@("DIAG NOSIS")=IE N"RTN","PX RPC",124,0 ) . . . S  @ROOT@("PR IMARY")=$S (PXDXI=1:$ P(X,U,5),1 :0)"RTN"," PXRPC",125 ,0) . . .  S LEXIEN=$ P($$EXP^LE XCODE(PXDX ,CSYS,CDT) ,U),@ROOT@ ("LEXICON  TERM")=$S( LEXIEN>0:L EXIEN,1:"" )"RTN","PX RPC",126,0 ) . . . S: $L(CAT) @R OOT@("CATE GORY")=CAT "RTN","PXR PC",127,0)  . . . S:$ L(NARR) @R OOT@("NARR ATIVE")=NA RR"RTN","P XRPC",128, 0) . . . S :$P(X,U,6) >0 @ROOT@( "ENC PROVI DER")=$P(X ,U,6)"RTN" ,"PXRPC",1 29,0) . .  . I $L($P( X,U,7)),($ P(X,U,7)=1 ),(PXDXI=1 ) S @ROOT@ ("PL ADD") =$P(X,U,7) ,PROBLEMS( ICD)=NARR_ U_CODE"RTN ","PXRPC", 130,0) . .  . S:$L($P (X,U,10))> 0&(PXDXI=1 ) COMMENT( $P(X,U,10) )="DX/PL^" _ICD"RTN", "PXRPC",13 1,0) . . .  I $E(TYP, 4)="-" S @ ROOT@("DEL ETE")=1"RT N","PXRPC" ,132,0) .  I $E(TYP,1 ,3)="IMM"  D  Q"RTN", "PXRPC",13 3,0) . . ;  If the CV X Code is  present, t hen use it  to find t he corresp onding Imm unization, "RTN","PXR PC",134,0)  . . ; but  only if t he Immuniz ation IEN  is not spe cified"RTN ","PXRPC", 135,0) . .  S IMMCVX= $P(X,U,11) "RTN","PXR PC",136,0)  . . I COD E="",IMMCV X'="" S CO DE=$$FIND1 ^DIC(99999 99.14,,,IM MCVX,"C",, "IMMCVXER" )"RTN","PX RPC",137,0 ) . . Q:'$ L(CODE)"RT N","PXRPC" ,138,0) .  . S IMM=IM M+1,ROOT=P XPCEARR_"( ""IMMUNIZA TION"","_I MM_")""RTN ","PXRPC", 139,0) . .  S @ROOT@( "IMMUN")=C ODE"RTN"," PXRPC",140 ,0) . . I  IMMCVX'=""  S @ROOT@( "CVX")=IMM CVX"RTN"," PXRPC",141 ,0) . . S: $L($P(X,U, 5)) @ROOT@ ("SERIES") =$P(X,U,5) "RTN","PXR PC",142,0)  . . S:$L( $P(X,U,7))  @ROOT@("R EACTION")= $P(X,U,7)" RTN","PXRP C",143,0)  . . S:$L($ P(X,U,8))  @ROOT@("CO NTRAINDICA TED")=$P(X ,U,8)"RTN" ,"PXRPC",1 44,0) . .  S:$L($P(X, U,9)) @ROO T@("REFUSE D")=$P(X,U ,9)"RTN"," PXRPC",145 ,0) . . S: $P(X,U,6)> 0 @ROOT@(" ENC PROVID ER")=$P(X, U,6)"RTN", "PXRPC",14 6,0) . . S :$L($P(X,U ,10))>0 CO MMENT($P(X ,U,10))="I MMUNIZATIO N^"_IMM"RT N","PXRPC" ,147,0) .  . ; These  are the ad ditional f ields bein g added by  PX*1.0*20 9"RTN","PX RPC",148,0 ) . . S IM MISIEN=$$I MMSRC($P(X ,U,12))"RT N","PXRPC" ,149,0) .  . S:IMMISI EN @ROOT@( "INFO SOUR CE")=IMMIS IEN"RTN"," PXRPC",150 ,0) . . S  IMMRTIEN=$ $IMMROUTE( $P(X,U,14) )"RTN","PX RPC",151,0 ) . . S:IM MRTIEN @RO OT@("ADMIN  ROUTE")=I MMRTIEN"RT N","PXRPC" ,152,0) .  . S IMMALI EN=$$IMMLO C($P(X,U,1 5))"RTN"," PXRPC",153 ,0) . . S: IMMALIEN @ ROOT@("ANA TOMIC LOC" )=IMMALIEN "RTN","PXR PC",154,0)  . . S IMM LOT=$$IMML OT($P(X,U, 16),$P(X,U ,17),$P(X, U,18))"RTN ","PXRPC", 155,0) . .  S IMMLOTI EN=$P(IMML OT,"^",1)" RTN","PXRP C",156,0)  . . S IMMC OMM=$P(IMM LOT,"^",2) "RTN","PXR PC",157,0)  . . S:IMM LOTIEN @RO OT@("LOT N UM")=IMMLO TIEN"RTN", "PXRPC",15 8,0) . . S  IMMDSG=$$ IMMDSG($P( X,U,13))"R TN","PXRPC ",159,0) .  . I $P(IM MDSG,U,1)' ="" D"RTN" ,"PXRPC",1 60,0) . .  . S @ROOT@ ("DOSE")=$ P(IMMDSG,U ,1)"RTN"," PXRPC",161 ,0) . . .  I $P(IMMDS G,U,2) S @ ROOT@("DOS E UNITS")= $P(IMMDSG, U,2)"RTN", "PXRPC",16 2,0) . . I  $P(IMMDSG ,U,3)'=""  D  ; add D osage to c omments"RT N","PXRPC" ,163,0) .  . . S IMMC OMM=$S($G( IMMCOMM)'= "":IMMCOMM _"; ",1:"" )_$P(IMMDS G,U,3)"RTN ","PXRPC", 164,0) . .  I IMMCOMM '="" D"RTN ","PXRPC", 165,0) . .  . ; If we  have some thing to a dd to the  Imm commen t, either  add it to  the existi ng comment "RTN","PXR PC",166,0)  . . . ; ( if one exi sts) or ju st set it  in the COM MENT field ."RTN","PX RPC",167,0 ) . . . I  $L($P(X,U, 10)) S IMM COMMS($P(X ,U,10))=IM MCOMM ; Th is will ge t added la ter to the  existing  comment"RT N","PXRPC" ,168,0) .  . . E  S @ ROOT@("COM MENT")=IMM COMM"RTN", "PXRPC",16 9,0) . . S :$P(X,U,19 )>0 @ROOT@ ("EVENT D/ T")=$P(X,U ,19)"RTN", "PXRPC",17 0,0) . . S :$P(X,U,20 )>0 @ROOT@ ("ORD PROV IDER")=$P( X,U,20)"RT N","PXRPC" ,171,0) .  . I $P(X,U ,21)'="" D  IMMVIS($P (X,U,21),R OOT)"RTN", "PXRPC",17 2,0) . . I  $P(X,U,22 )'="" D IM MRMRKS($P( X,U,22),IM M,.REMARK) "RTN","PXR PC",173,0)  . . I $P( X,U,23)'=" " S @ROOT@ ("WARNING  ACK")=$P(X ,U,23)"RTN ","PXRPC", 174,0) . .  I $P(X,U, 24)>0 S IM MOVERRIDE( $P(X,U,24) )="IMMUNIZ ATION^"_IM M"RTN","PX RPC",175,0 ) . . I $E (TYP,4)="- " S @ROOT@ ("DELETE") =1"RTN","P XRPC",176, 0) . I $E( TYP,1,2)=" SK" D  Q"R TN","PXRPC ",177,0) .  . Q:'$L(C ODE)"RTN", "PXRPC",17 8,0) . . S  SK=SK+1,R OOT=PXPCEA RR_"(""SKI N TEST""," _SK_")""RT N","PXRPC" ,179,0) .  . S @ROOT@ ("TEST")=C ODE"RTN"," PXRPC",180 ,0) . . S: $L($P(X,U, 5)) @ROOT@ ("RESULT") =$P(X,U,5) "RTN","PXR PC",181,0)  . . S:$L( $P(X,U,7))  @ROOT@("R EADING")=$ P(X,U,7)"R TN","PXRPC ",182,0) .  . S:$L($P (X,U,8)) @ ROOT@("D/T  READ")=$P (X,U,8)"RT N","PXRPC" ,183,0) .  . S:$L($P( X,U,9)) @R OOT@("EVEN T D/T")=$P (X,U,9)"RT N","PXRPC" ,184,0) .  . S:$P(X,U ,6)>0 @ROO T@("ENC PR OVIDER")=$ P(X,U,6)"R TN","PXRPC ",185,0) .  . S:$L($P (X,U,10))> 0 COMMENT( $P(X,U,10) )="SKIN TE ST^"_SK"RT N","PXRPC" ,186,0) .  . S:$P(X,U ,11)>0 @RO OT@("READE R")=$P(X,U ,11) ; PX* 1*216"RTN" ,"PXRPC",1 87,0) . .  S:$P(X,U,1 2)>0 @ROOT @("ORD PRO VIDER")=$P (X,U,12) ;  PX*1*216" RTN","PXRP C",188,0)  . . S IMMA LIEN=$$IMM LOC($P(X,U ,13)) ; PX *1*216"RTN ","PXRPC", 189,0) . .  S:IMMALIE N @ROOT@(" ANATOMIC L OC")=IMMAL IEN ; PX*1 *216"RTN", "PXRPC",19 0,0) . . I  $P(X,U,14 )>0 S SKRD COM($P(X,U ,14))="SKI N TEST^"_S K ; PX*1*2 16"RTN","P XRPC",191, 0) . . I $ E(TYP,3)=" -" S @ROOT @("DELETE" )=1"RTN"," PXRPC",192 ,0) . I $E (TYP,1,3)= "PED" D  Q "RTN","PXR PC",193,0)  . . Q:'$L (CODE)"RTN ","PXRPC", 194,0) . .  S PED=PED +1,ROOT=PX PCEARR_"(" "PATIENT E D"","_PED_ ")""RTN"," PXRPC",195 ,0) . . S  @ROOT@("TO PIC")=CODE "RTN","PXR PC",196,0)  . . S:$L( $P(X,U,5))  @ROOT@("U NDERSTANDI NG")=$P(X, U,5)"RTN", "PXRPC",19 7,0) . . S :$P(X,U,6) >0 @ROOT@( "ENC PROVI DER")=$P(X ,U,6)"RTN" ,"PXRPC",1 98,0) . .  S:$L($P(X, U,10))>0 C OMMENT($P( X,U,10))=" PATIENT ED ^"_PED"RTN ","PXRPC", 199,0) . .  I $E(TYP, 4)="-" S @ ROOT@("DEL ETE")=1"RT N","PXRPC" ,200,0) .  I $E(TYP,1 ,2)="HF" D   Q"RTN"," PXRPC",201 ,0) . . Q: '$L(CODE)" RTN","PXRP C",202,0)  . . S HF=H F+1,ROOT=P XPCEARR_"( ""HEALTH F ACTOR"","_ HF_")""RTN ","PXRPC", 203,0) . .  S @ROOT@( "HEALTH FA CTOR")=COD E"RTN","PX RPC",204,0 ) . . S:$L ($P(X,U,5) ) @ROOT@(" LEVEL/SEVE RITY")=$P( X,U,5)"RTN ","PXRPC", 205,0) . .  S:$P(X,U, 6)'>0 $P(X ,U,6)=$G(@ PXPCEARR@( "PROVIDER" ,1,"NAME") )"RTN","PX RPC",206,0 ) . . S:$P (X,U,6)>0  @ROOT@("EN C PROVIDER ")=$P(X,U, 6)"RTN","P XRPC",207, 0) . . S:$ L($P(X,U,1 1)) @ROOT@ ("EVENT D/ T")=$P($P( X,U,11),"; ",1)"RTN", "PXRPC",20 8,0) . . S :$L($P(X,U ,11)) SRC= $P($P(X,U, 11),";",2) "RTN","PXR PC",209,0)  . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="HEALT H FACTOR^" _HF"RTN"," PXRPC",210 ,0) . . I  $E(TYP,3)= "-" S @ROO T@("DELETE ")=1"RTN", "PXRPC",21 1,0) . I $ E(TYP,1,3) ="XAM" D   Q"RTN","PX RPC",212,0 ) . . Q:'$ L(CODE)"RT N","PXRPC" ,213,0) .  . S XAM=XA M+1,ROOT=P XPCEARR_"( ""EXAM""," _XAM_")""R TN","PXRPC ",214,0) .  . S @ROOT @("EXAM")= CODE"RTN", "PXRPC",21 5,0) . . S :$L($P(X,U ,5)) @ROOT @("RESULT" )=$P(X,U,5 )"RTN","PX RPC",216,0 ) . . S:$P (X,U,6)>0  @ROOT@("EN C PROVIDER ")=$P(X,U, 6)"RTN","P XRPC",217, 0) . . S:$ L($P(X,U,1 0))>0 COMM ENT($P(X,U ,10))="EXA M^"_XAM"RT N","PXRPC" ,218,0) .  . I $E(TYP ,4)="-" S  @ROOT@("DE LETE")=1"R TN","PXRPC ",219,0) .  I $E(TYP, 1,3)="TRT"  D  Q"RTN" ,"PXRPC",2 20,0) . .  Q:'$L(CODE )"RTN","PX RPC",221,0 ) . . S TR T=TRT+1,RO OT=PXPCEAR R_"(""TREA TMENT"","_ TRT_")""RT N","PXRPC" ,222,0) .  . S @ROOT@ ("IMMUN")= CODE"RTN", "PXRPC",22 3,0) . . S :$L(CAT) @ ROOT@("CAT EGORY")=CA T"RTN","PX RPC",224,0 ) . . S:$L (NARR) @RO OT@("NARRA TIVE")=NAR R"RTN","PX RPC",225,0 ) . . S:$L ($P(X,U,5) ) @ROOT@(" QTY")=$P(X ,U,5)"RTN" ,"PXRPC",2 26,0) . .  S:$P(X,U,6 )>0 @ROOT@ ("ENC PROV IDER")=$P( X,U,6)"RTN ","PXRPC", 227,0) . .  S:$L($P(X ,U,10))>0  COMMENT($P (X,U,10))= "TREATMENT ^"_TRT"RTN ","PXRPC", 228,0) . .  I $E(TYP, 4)="-" S @ ROOT@("DEL ETE")=1,@R OOT@("QTY" )=0"RTN"," PXRPC",229 ,0) . I $E (TYP,1,3)= "ICR" D  Q "RTN","PXR PC",230,0)  . . Q:'$L (CODE)"RTN ","PXRPC", 231,0) . .  S ICR=ICR +1,ROOT=PX PCEARR_"(" "IMM CONTR A/REFUSAL" ","_ICR_") ""RTN","PX RPC",232,0 ) . . S @R OOT@("CONT RA/REFUSAL ")=CODE"RT N","PXRPC" ,233,0) .  . I $P(X,U ,5)'="" S  @ROOT@("IM MUN")=$$TR IM^XLFSTR( $P(X,U,5)) "RTN","PXR PC",234,0)  . . I $P( X,U,6)'=""  S @ROOT@( "WARN UNTI L DATE")=$ $TRIM^XLFS TR($P(X,U, 6))"RTN"," PXRPC",235 ,0) . . I  $P(X,U,7)' ="" S @ROO T@("EVENT  D/T")=$$TR IM^XLFSTR( $P(X,U,7)) "RTN","PXR PC",236,0)  . . I $P( X,U,8)'=""  S @ROOT@( "ENC PROVI DER")=$$TR IM^XLFSTR( $P(X,U,8)) "RTN","PXR PC",237,0)  . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="IMM C ONTRA/REFU SAL^"_ICR" RTN","PXRP C",238,0)  . . I $E(T YP,4)="-"  S @ROOT@(" DELETE")=1 "RTN","PXR PC",239,0)  . I $E(TY P,1,3)="CO M" D  Q"RT N","PXRPC" ,240,0) .  . Q:'$L(CO DE)"RTN"," PXRPC",241 ,0) . . Q: '$L(CAT)"R TN","PXRPC ",242,0) .  . S COMME NTS(CODE)= $P(X,U,3,9 99)"RTN"," PXRPC",243 ,0) ;Store  the comme nts"RTN"," PXRPC",244 ,0) S COM= """RTN","P XRPC",245, 0) ;F  S C OM=$O(COMM ENT(COM))  Q:COM=""   S:$D(COMME NTS(COM))  PXAPI($P(C OMMENT(COM ),"^",1),$ P(COMMENT( COM),"^",2 ),"COMMENT ")=COMMENT S(COM)"RTN ","PXRPC", 246,0) F   S COM=$O(C OMMENT(COM )) Q:COM=" "  D:$D(CO MMENTS(COM ))"RTN","P XRPC",247, 0) . I $G( IMMCOMMS(C OM))'="" D "RTN","PXR PC",248,0)  . . I COM MENTS(COM) ="@" S COM MENTS(COM) ="""RTN"," PXRPC",249 ,0) . . S  COMMENTS(C OM)=COMMEN TS(COM)_$S (COMMENTS( COM)="":"" ,1:" ")_IM MCOMMS(COM )"RTN","PX RPC",250,0 ) . S @PXP CEARR@($P( COMMENT(CO M),"^",1), $P(COMMENT (COM),"^", 2),"COMMEN T")=COMMEN TS(COM)"RT N","PXRPC" ,251,0) ;" RTN","PXRP C",252,0)  ;Store the  Remarks ( currently  used by im munization s) - PX,21 0"RTN","PX RPC",253,0 ) S COM="" "RTN","PXR PC",254,0)  F  S COM= $O(REMARK( COM)) Q:CO M=""  I $D (COMMENTS( COM)) D"RT N","PXRPC" ,255,0) .  S TYP=$P(R EMARK(COM) ,"^",1)"RT N","PXRPC" ,256,0) .  S NUM=$P(R EMARK(COM) ,"^",2)"RT N","PXRPC" ,257,0) .  S SEQ=$O(@ PXPCEARR@( TYP,NUM,"R EMARKS","" ),-1)+1"RT N","PXRPC" ,258,0) .  S @PXPCEAR R@(TYP,NUM ,"REMARKS" ,SEQ,0)=CO MMENTS(COM )"RTN","PX RPC",259,0 ) ;"RTN"," PXRPC",260 ,0) ;Store  the Immun ization Ov erride Rea son - PX,2 15"RTN","P XRPC",261, 0) S COM=" ""RTN","PX RPC",262,0 ) F  S COM =$O(IMMOVE RRIDE(COM) ) Q:COM=""   I $G(COM MENTS(COM) )'="" D"RT N","PXRPC" ,263,0) .  S TYP=$P(I MMOVERRIDE (COM),"^", 1)"RTN","P XRPC",264, 0) . S NUM =$P(IMMOVE RRIDE(COM) ,"^",2)"RT N","PXRPC" ,265,0) .  S @PXPCEAR R@(TYP,NUM ,"OVERRIDE  REASON")= COMMENTS(C OM)"RTN"," PXRPC",266 ,0) ;"RTN" ,"PXRPC",2 67,0) ;Sto re the Ski n Test Rea ding Comme nt - PX*1* 216"RTN"," PXRPC",268 ,0) S COM= """RTN","P XRPC",269, 0) F  S CO M=$O(SKRDC OM(COM)) Q :COM=""  I  $G(COMMEN TS(COM))'= "" D"RTN", "PXRPC",27 0,0) . S T YP=$P(SKRD COM(COM)," ^",1)"RTN" ,"PXRPC",2 71,0) . S  NUM=$P(SKR DCOM(COM), "^",2)"RTN ","PXRPC", 272,0) . S  @PXPCEARR @(TYP,NUM, "READING C OMMENT")=C OMMENTS(CO M)"RTN","P XRPC",273, 0) ;"RTN", "PXRPC",27 4,0) S @PX PCEARR@("E NCOUNTER", 1,"ENCOUNT ER TYPE")= "P""RTN"," PXRPC",275 ,0) ;"RTN" ,"PXRPC",2 76,0) Q"RT N","PXRPC" ,277,0) ;" RTN","PXRP C",278,0)D ATA2PCE(OK ,PXPCEARR, PKG,SRC,PX AVST,PXERR OR) ;"RTN" ,"PXRPC",2 79,0) I '( $D(PXAVST) #2) S PXAV ST="""RTN" ,"PXRPC",2 80,0) S OK =$$DATA2PC E^PXAI(PXP CEARR,PKG, SRC,.PXAVS T,"","",.P XERROR,"", "","")"RTN ","PXRPC", 281,0) Q"R TN","PXRPC ",282,0) ; "RTN","PXR PC",283,0) IMMSRC(IMM IS) ; Retu rns Event  Info Sourc e IEN"RTN" ,"PXRPC",2 84,0) N IM MISHL,IMMI SIEN,X"RTN ","PXRPC", 285,0) S I MMISHL=$P( IMMIS,";", 1)"RTN","P XRPC",286, 0) S IMMIS IEN=$P(IMM IS,";",2)" RTN","PXRP C",287,0)  ; Look up  the value  in the "H"  Cross-ref erence"RTN ","PXRPC", 288,0) I ' IMMISIEN D "RTN","PXR PC",289,0)  . S IMMIS IEN=$$FIND 1^DIC(920. 1,,,IMMISH L,"H",,"IM MISERR")"R TN","PXRPC ",290,0) Q  IMMISIEN" RTN","PXRP C",291,0)  ;"RTN","PX RPC",292,0 )IMMROUTE( IMMRT) ; R eturns Rou te IEN"RTN ","PXRPC", 293,0) N I MMRTHL,IMM RTIEN,IMMR TNM,X"RTN" ,"PXRPC",2 94,0) S IM MRTNM=$P(I MMRT,";",1 )"RTN","PX RPC",295,0 ) S IMMRTH L=$P(IMMRT ,";",2)"RT N","PXRPC" ,296,0) S  IMMRTIEN=$ P(IMMRT,"; ",3)"RTN", "PXRPC",29 7,0) I 'IM MRTIEN,IMM RTHL'="" D "RTN","PXR PC",298,0)  . S IMMRT IEN=$$FIND 1^DIC(920. 2,,,IMMRTH L,"H",,"IM MRTERR")"R TN","PXRPC ",299,0) I  'IMMRTIEN ,IMMRTNM'= "" D"RTN", "PXRPC",30 0,0) . S I MMRTIEN=$$ FIND1^DIC( 920.2,,,IM MRTNM,"B", ,"IMMRTERR ")"RTN","P XRPC",301, 0) Q IMMRT IEN"RTN"," PXRPC",302 ,0) ;"RTN" ,"PXRPC",3 03,0)IMMLO C(IMMAL) ;  Returns A natomic Lo cation IEN "RTN","PXR PC",304,0)  N IMMALHL ,IMMALIEN, IMMALNM,X" RTN","PXRP C",305,0)  S IMMALNM= $P(IMMAL," ;",1)"RTN" ,"PXRPC",3 06,0) S IM MALHL=$P(I MMAL,";",2 )"RTN","PX RPC",307,0 ) S IMMALI EN=$P(IMMA L,";",3)"R TN","PXRPC ",308,0) I  'IMMALIEN ,IMMALHL'= "" D"RTN", "PXRPC",30 9,0) . S I MMALIEN=$$ FIND1^DIC( 920.3,,,IM MALHL,"B", ,"IMMALERR ")"RTN","P XRPC",310, 0) I 'IMMA LIEN,IMMAL NM'="" D"R TN","PXRPC ",311,0) .  S IMMALIE N=$$FIND1^ DIC(920.3, ,,IMMALNM, "B",,"IMMA LERR")"RTN ","PXRPC", 312,0) Q I MMALIEN"RT N","PXRPC" ,313,0) ;" RTN","PXRP C",314,0)I MMLOT(IMML OT,IMMMANU F,IMMEXPDT ) ; Return s Lot_IEN^ Comment"RT N","PXRPC" ,315,0) N  IMMCOMM,IM MLOTIEN,IM MLOTNM,X"R TN","PXRPC ",316,0) S  IMMLOTNM= $P(IMMLOT, ";",1)"RTN ","PXRPC", 317,0) S I MMLOTIEN=$ P(IMMLOT," ;",2)"RTN" ,"PXRPC",3 18,0) ;"RT N","PXRPC" ,319,0) I  IMMLOTIEN  Q IMMLOTIE N"RTN","PX RPC",320,0 ) ;"RTN"," PXRPC",321 ,0) ; If t he Lot Num ber, Manuf acturer an d Expirati on Date ar e all spec ified,"RTN ","PXRPC", 322,0) ; t hen find a n entry ma tching all  three val ues in Fil e 9999999. 41 (IMMUNI ZATION LOT )"RTN","PX RPC",323,0 ) ; If we  don't find  a match,  then add t he fields  to the Com ment."RTN" ,"PXRPC",3 24,0) ; Fo r now, we  will not r eceive the  Expiratio n Date fro m Walgreen s, so we a lways upda te the Com ment."RTN" ,"PXRPC",3 25,0) S IM MCOMM="""R TN","PXRPC ",326,0) S :IMMLOTNM' ="" IMMCOM M=IMMCOMM_ $S(IMMCOMM ="":"",1:"  ")_"Lot#:  "_IMMLOTN M"RTN","PX RPC",327,0 ) S:IMMMAN UF'="" IMM COMM=IMMCO MM_$S(IMMC OMM="":"", 1:" ")_"Mf r: "_IMMMA NUF"RTN"," PXRPC",328 ,0) S:IMME XPDT'="" I MMCOMM=IMM COMM_$S(IM MCOMM="":" ",1:" ")_" Expiration  Date: "_I MMEXPDT"RT N","PXRPC" ,329,0) Q  "^"_IMMCOM M"RTN","PX RPC",330,0 ) ;"RTN"," PXRPC",331 ,0)IMMVIS( IMMVISMULT ,ROOT) ; S ets ROOT's  VIS multi ple"RTN"," PXRPC",332 ,0) N IMMV IS,IMMVISD T,IMMVISEN TRY,PXSEQ, PXX,X"RTN" ,"PXRPC",3 33,0) S PX SEQ=0"RTN" ,"PXRPC",3 34,0) F PX X=1:1:$L(I MMVISMULT, ";") D"RTN ","PXRPC", 335,0) . S  IMMVISENT RY=$$TRIM^ XLFSTR($P( IMMVISMULT ,";",PXX)) "RTN","PXR PC",336,0)  . S IMMVI S=$P(IMMVI SENTRY,"/" ,1)"RTN"," PXRPC",337 ,0) . I 'I MMVIS Q"RT N","PXRPC" ,338,0) .  S IMMVISDT =$P(IMMVIS ENTRY,"/", 2)"RTN","P XRPC",339, 0) . I IMM VISDT S IM MVIS=IMMVI S_U_IMMVIS DT"RTN","P XRPC",340, 0) . S PXS EQ=PXSEQ+1 "RTN","PXR PC",341,0)  . S @ROOT @("VIS",PX SEQ,0)=IMM VIS"RTN"," PXRPC",342 ,0) Q"RTN" ,"PXRPC",3 43,0) ;"RT N","PXRPC" ,344,0)IMM RMRKS(IMMR EMARKS,IMM NUM,REMARK ) ; Sets R EMARK arra y"RTN","PX RPC",345,0 ) N PXEND, PXSTART,PX X,X"RTN"," PXRPC",346 ,0) S PXST ART=$P(IMM REMARKS,"; ",1)"RTN", "PXRPC",34 7,0) S PXE ND=$P(IMMR EMARKS,";" ,2)"RTN"," PXRPC",348 ,0) I ('PX START)!('P XEND)!(PXE ND<PXSTART ) Q"RTN"," PXRPC",349 ,0) F PXX= PXSTART:1: PXEND D"RT N","PXRPC" ,350,0) .  S REMARK(P XX)="IMMUN IZATION^"_ IMMNUM"RTN ","PXRPC", 351,0) Q"R TN","PXRPC ",352,0) ; "RTN","PXR PC",353,0) IMMDSG(IMM DSG) ;"RTN ","PXRPC", 354,0) N I MMDOSE,IMM UNIT,IMMUN ITIEN,IMMD OSEV,IMMUN ERR,X"RTN" ,"PXRPC",3 55,0) S IM MDSG=$$TRI M^XLFSTR(I MMDSG)"RTN ","PXRPC", 356,0) I I MMDSG="" Q  """RTN"," PXRPC",357 ,0) S IMMD OSE=$P(IMM DSG,";",1) "RTN","PXR PC",358,0)  S IMMUNIT =$P(IMMDSG ,";",2)"RT N","PXRPC" ,359,0) S  IMMUNITIEN =$P(IMMDSG ,";",3)"RT N","PXRPC" ,360,0) I  IMMDSG[" " ,IMMDSG'[" ;" D  ;Rem ove this D O block wh en VLER DA S starts u sing ";" b etween dos e and unit s"RTN","PX RPC",361,0 ) . S IMMD OSE=$P(IMM DSG," ",1) "RTN","PXR PC",362,0)  . S IMMUN IT=$P(IMMD SG," ",2)" RTN","PXRP C",363,0)  ;"RTN","PX RPC",364,0 ) I IMMDOS E="" Q """ RTN","PXRP C",365,0)  ;"RTN","PX RPC",366,0 ) I IMMUNI T'="",'IMM UNITIEN D" RTN","PXRP C",367,0)  . N UCUMDA TA"RTN","P XRPC",368, 0) . D UCU MDATA^LEXM UCUM(IMMUN IT,.UCUMDA TA)  ; ICR  6225"RTN" ,"PXRPC",3 69,0) . S  IMMUNITIEN =$O(UCUMDA TA(0))"RTN ","PXRPC", 370,0) D C HK^DIE(900 0010.11,13 12,,IMMDOS E,.IMMDOSE V,"IMMUNER R")"RTN"," PXRPC",371 ,0) I IMMU NITIEN,IMM DOSEV'="^"  Q IMMDOSE V_U_IMMUNI TIEN"RTN", "PXRPC",37 2,0) ;"RTN ","PXRPC", 373,0) Q U _U_"Dosage : "_IMMDOS E_" "_IMMU NIT"RTN"," PXUTLSCC") 0^28^B4572 3693"RTN", "PXUTLSCC" ,1,0)PXUTL SCC ;ISL/d ee,ISA/KWP  - Validat es and cor rects the  Service Co nnected Co nditions ; 6/06/05"RT N","PXUTLS CC",2,0) ; ;1.0;PCE P ATIENT CAR E ENCOUNTE R;**74,107 ,111,130,1 68,207**;A ug 12, 199 6;Build 54 "RTN","PXU TLSCC",3,0 ) Q"RTN"," PXUTLSCC", 4,0) ;"RTN ","PXUTLSC C",5,0)SCC (PXUPAT,PX UDT,PXUHLO C,PXUTLVST ,PXUIN,PXU OUT,PXUERR ) ;"RTN"," PXUTLSCC", 6,0) ;+Inp ut Paramet ers:"RTN", "PXUTLSCC" ,7,0) ;+   PXUPAT   I EN of pati ent"RTN"," PXUTLSCC", 8,0) ;+  P XUDT    da te and tim e of the e ncounter"R TN","PXUTL SCC",9,0)  ;+  PXUHLO C  Hospita l Location  of the en ocunter"RT N","PXUTLS CC",10,0)  ;+  PXUTLV ST (option al) pointe r to the v isit that  is being u sed"RTN"," PXUTLSCC", 11,0) ;+   PXUIN    s ervice con nected^age nt orange^ ionizing r adiation"R TN","PXUTL SCC",12,0)  ;+              ^env iromental  contaminan ts^militar y sexual t rauma"RTN" ,"PXUTLSCC ",13,0) ;+               ^head a nd/or neck  cancer^co mbat veter an^shad^ca mp lejeune "RTN","PXU TLSCC",14, 0) ;+            wher e 1 ::= ye s, 0 ::= n o, null :: = n/a"RTN" ,"PXUTLSCC ",15,0) ;+ "RTN","PXU TLSCC",16, 0) ;+Outpu t Paramete rs:"RTN"," PXUTLSCC", 17,0) ;+   PXUOUT  th is is PXUI N correcte d so that  the invali d answers" RTN","PXUT LSCC",18,0 ) ;+           are ch anged to n ull"RTN"," PXUTLSCC", 19,0) ;+   PXUERR  th is is a si x piece va lue one fo r each con dition as  follows:"R TN","PXUTL SCC",20,0)  ;+      1    ::= sho uld be yes  or no, bu t it is nu ll"RTN","P XUTLSCC",2 1,0) ;+       0   ::=  no error" RTN","PXUT LSCC",22,0 ) ;+     - 1   ::= no t valued v alue"RTN", "PXUTLSCC" ,23,0) ;+      -2   : := value m ust be nul l"RTN","PX UTLSCC",24 ,0) ;+      -3   ::=  must be nu ll because  SC is yes "RTN","PXU TLSCC",25, 0) ;"RTN", "PXUTLSCC" ,26,0) N P XUITEM,PXU PSCC,PXUSC ,PXUAO,PXU IR,PXUEC,P XUMST,PXUH NC,PXUSHAD ,PXUCLV"RT N","PXUTLS CC",27,0)  D SCCOND(P XUPAT,PXUD T,PXUHLOC, $G(PXUTLVS T),.PXUPSC C) ;Set up  array of  the patien ts SCC"RTN ","PXUTLSC C",28,0) S  PXUOUT=PX UIN"RTN"," PXUTLSCC", 29,0) ;  d js  PX*1.0 *207  RSD  SPEC #2.6. 2.4.2.1 &  2.6.2.4.3. 1  Added p iece #9 to  error var iable for  Camp Lejeu ne"RTN","P XUTLSCC",3 0,0) S PXU ERR="0^0^0 ^0^0^0^0^0 ^0""RTN"," PXUTLSCC", 31,0) S PX USC=$P(PXU IN,"^",1)" RTN","PXUT LSCC",32,0 ) I '(PXUS C=1!(PXUSC =0)!(PXUSC ="")) S $P (PXUERR,"^ ",1)=-1 S  $P(PXUOUT, "^",1)=""" RTN","PXUT LSCC",33,0 ) E  I PXU SC="" D  ; it is ok"R TN","PXUTL SCC",34,0)  . I $P(PX UPSCC("SC" ),"^",1) S  $P(PXUERR ,"^",1)=1, $P(PXUOUT, "^",1)=$P( PXUPSCC("S C"),"^",2)  ;should h ave had a  value"RTN" ,"PXUTLSCC ",35,0) E   I PXUSC]" " D"RTN"," PXUTLSCC", 36,0) . I  '$P(PXUPSC C("SC"),"^ ",1) S $P( PXUERR,"^" ,1)=-2 S $ P(PXUOUT," ^",1)="" ; it must be  null"RTN" ,"PXUTLSCC ",37,0) .  E  ;it is  ok"RTN","P XUTLSCC",3 8,0) S PXU SC=$P(PXUO UT,"^",1)" RTN","PXUT LSCC",39,0 ) S PXUAO= $P(PXUIN," ^",2)"RTN" ,"PXUTLSCC ",40,0) I  '(PXUAO=1! (PXUAO=0)! (PXUAO="") ) S $P(PXU ERR,"^",2) =-1 S $P(P XUOUT,"^", 2)="""RTN" ,"PXUTLSCC ",41,0) E   I PXUAO=" " D  ;it i s ok"RTN", "PXUTLSCC" ,42,0) . I  $P(PXUPSC C("AO"),"^ ",1),'PXUS C S $P(PXU ERR,"^",2) =1,$P(PXUO UT,"^",2)= $P(PXUPSCC ("AO"),"^" ,2) ;shoul d have had  a value"R TN","PXUTL SCC",43,0)  E  I PXUA O]"" D"RTN ","PXUTLSC C",44,0) .  I '$P(PXU PSCC("AO") ,"^",1) S  $P(PXUERR, "^",2)=-2  S $P(PXUOU T,"^",2)=" " ;it must  be null"R TN","PXUTL SCC",45,0)  . E  I PX USC,PXUAO] "" S $P(PX UERR,"^",2 )=-3 S $P( PXUOUT,"^" ,2)="" ;it  is SC so  it must be  null"RTN" ,"PXUTLSCC ",46,0) .  ;E  ;it is  ok"RTN"," PXUTLSCC", 47,0) S PX UIR=$P(PXU IN,"^",3)" RTN","PXUT LSCC",48,0 ) I '(PXUI R=1!(PXUIR =0)!(PXUIR ="")) S $P (PXUERR,"^ ",3)=-1 S  $P(PXUOUT, "^",3)=""" RTN","PXUT LSCC",49,0 ) E  I PXU IR="" D  ; it is ok"R TN","PXUTL SCC",50,0)  . I $P(PX UPSCC("IR" ),"^",1),' PXUSC S $P (PXUERR,"^ ",3)=1,$P( PXUOUT,"^" ,3)=$P(PXU PSCC("IR") ,"^",2) ;s hould have  had a val ue"RTN","P XUTLSCC",5 1,0) E  I  PXUIR]"" D "RTN","PXU TLSCC",52, 0) . I '$P (PXUPSCC(" IR"),"^",1 ) S $P(PXU ERR,"^",3) =-2 S $P(P XUOUT,"^", 3)="" ;it  must be nu ll"RTN","P XUTLSCC",5 3,0) . E   I PXUSC,PX UIR]"" S $ P(PXUERR," ^",3)=-3 S  $P(PXUOUT ,"^",3)=""  ;it is SC  so it mus t be null" RTN","PXUT LSCC",54,0 ) . ;E  ;i t is ok"RT N","PXUTLS CC",55,0)  S PXUEC=$P (PXUIN,"^" ,4)"RTN"," PXUTLSCC", 56,0) I '( PXUEC=1!(P XUEC=0)!(P XUEC=""))  S $P(PXUER R,"^",4)=- 1 S $P(PXU OUT,"^",4) ="""RTN"," PXUTLSCC", 57,0) E  I  PXUEC=""  D  ;it is  ok"RTN","P XUTLSCC",5 8,0) . I $ P(PXUPSCC( "EC"),"^", 1),'PXUSC  S $P(PXUER R,"^",4)=1 ,$P(PXUOUT ,"^",4)=$P (PXUPSCC(" EC"),"^",2 ) ;should  have had a  value"RTN ","PXUTLSC C",59,0) E   I PXUEC] "" D"RTN", "PXUTLSCC" ,60,0) . I  '$P(PXUPS CC("EC")," ^",1) S $P (PXUERR,"^ ",4)=-2 S  $P(PXUOUT, "^",4)=""  ;it must b e null"RTN ","PXUTLSC C",61,0) .  E  I PXUS C,PXUEC]""  S $P(PXUE RR,"^",4)= -3 S $P(PX UOUT,"^",4 )="" ;it i s SC so it  must be n ull"RTN"," PXUTLSCC", 62,0) . ;E   ;it is o k"RTN","PX UTLSCC",63 ,0) S PXUM ST=$P(PXUI N,"^",5) ; MST not de pendent on  SC questi on"RTN","P XUTLSCC",6 4,0) I '(P XUMST=1!(P XUMST=0)!( PXUMST="") ) S $P(PXU ERR,"^",5) =-1 S $P(P XUOUT,"^", 5)="" ;not  valid dat a"RTN","PX UTLSCC",65 ,0) E  I P XUMST="" D   ;it is o k"RTN","PX UTLSCC",66 ,0) . I $P (PXUPSCC(" MST"),"^", 1) S $P(PX UERR,"^",5 )=1,$P(PXU OUT,"^",5) =$P(PXUPSC C("MST")," ^",2) ;sho uld have h ad a value "RTN","PXU TLSCC",67, 0) E  I PX UMST]"" D" RTN","PXUT LSCC",68,0 ) .I '$P(P XUPSCC("MS T"),"^",1)  S $P(PXUE RR,"^",5)= -2 S $P(PX UOUT,"^",5 )="" ;it m ust be nul l, not MST  status"RT N","PXUTLS CC",69,0)  ;PX*1*111  - Add Head  & Neck"RT N","PXUTLS CC",70,0)  S PXUHNC=$ P(PXUIN,"^ ",6) ;HNC  not depend ent on SC  question"R TN","PXUTL SCC",71,0)  I '(PXUHN C=1!(PXUHN C=0)!(PXUH NC="")) S  $P(PXUERR, "^",6)=-1  S $P(PXUOU T,"^",6)=" " ;not val id data"RT N","PXUTLS CC",72,0)  E  I PXUHN C="" D  ;i t is ok"RT N","PXUTLS CC",73,0)  . I $P(PXU PSCC("HNC" ),"^",1) S  $P(PXUERR ,"^",6)=1, $P(PXUOUT, "^",6)=$P( PXUPSCC("H NC"),"^",2 ) ;should  have had a  value"RTN ","PXUTLSC C",74,0) E   I PXUHNC ]"" D"RTN" ,"PXUTLSCC ",75,0) .I  '$P(PXUPS CC("HNC"), "^",1) S $ P(PXUERR," ^",6)=-2 S  $P(PXUOUT ,"^",6)=""  ;it must  be null, n ot HNC sta tus"RTN"," PXUTLSCC", 76,0) S PX UCV=$P(PXU IN,"^",7)  ;CV not de pendent on  SC questi on"RTN","P XUTLSCC",7 7,0) I '(P XUCV=1!(PX UCV=0)!(PX UCV="")) S  $P(PXUERR ,"^",7)=-1  S $P(PXUO UT,"^",7)= "" ;not va lid data"R TN","PXUTL SCC",78,0)  E  I PXUC V="" D  ;i t is ok"RT N","PXUTLS CC",79,0)  . I $P(PXU PSCC("CV") ,"^",1) S  $P(PXUERR, "^",7)=1,$ P(PXUOUT," ^",7)=$P(P XUPSCC("CV "),"^",2)  ;should ha ve had a v alue"RTN", "PXUTLSCC" ,80,0) E   I PXUCV]""  D"RTN","P XUTLSCC",8 1,0) .I '$ P(PXUPSCC( "CV"),"^", 1) S $P(PX UERR,"^",7 )=-2 S $P( PXUOUT,"^" ,7)="" ;it  must be n ull, not C V status"R TN","PXUTL SCC",82,0)  S PXUSHAD =$P(PXUIN, "^",8) ;SH AD not dep endent on  SC questio n"RTN","PX UTLSCC",83 ,0) I '(PX USHAD=1!(P XUSHAD=0)! (PXUSHAD=" ")) S $P(P XUERR,"^", 8)=-1 S $P (PXUOUT,"^ ",8)="" ;n ot valid d ata"RTN"," PXUTLSCC", 84,0) E  I  PXUSHAD=" " D  ;it i s ok"RTN", "PXUTLSCC" ,85,0) . I  $P(PXUPSC C("SHAD"), "^",1) S $ P(PXUERR," ^",8)=1,$P (PXUOUT,"^ ",8)=$P(PX UPSCC("SHA D"),"^",2)  ;should h ave had a  value"RTN" ,"PXUTLSCC ",86,0) E   I PXUSHAD ]"" D"RTN" ,"PXUTLSCC ",87,0) .I  '$P(PXUPS CC("SHAD") ,"^",1) S  $P(PXUERR, "^",8)=-2  S $P(PXUOU T,"^",8)=" " ;it must  be null,  not SHAD s tatus"RTN" ,"PXUTLSCC ",88,0) ;   djs  PX*1 .0*207  RS D SPEC #2. 6.2.4.2.1  & 2.6.2.4. 3.1  Add v alidation  for Camp L ejeune"RTN ","PXUTLSC C",89,0) S  PXUCLV=$P (PXUIN,"^" ,9)"RTN"," PXUTLSCC", 90,0) I '( PXUCLV=1!( PXUCLV=0)! (PXUCLV="" )) S $P(PX UERR,"^",9 )=-1 S $P( PXUOUT,"^" ,9)="" ;no t valid da ta"RTN","P XUTLSCC",9 1,0) E  I  PXUCLV=""  D  ;it is  ok"RTN","P XUTLSCC",9 2,0) . I $ P(PXUPSCC( "CLV"),"^" ,1),'PXUSC  S $P(PXUE RR,"^",9)= 1,$P(PXUOU T,"^",9)=$ P(PXUPSCC( "CLV"),"^" ,2) ;shoul d have had  a value"R TN","PXUTL SCC",93,0)  E  I PXUC LV]"" D"RT N","PXUTLS CC",94,0)  .I '$P(PXU PSCC("CLV" ),"^",1) S  $P(PXUERR ,"^",9)=-2  S $P(PXUO UT,"^",9)= "" ;it mus t be null,  not CLV s tatus"RTN" ,"PXUTLSCC ",95,0) .  E  I PXUSC ,PXUCLV]""  S $P(PXUE RR,"^",9)= -3 S $P(PX UOUT,"^",9 )="" ;it i s SC so it  must be n ull"RTN"," PXUTLSCC", 96,0) Q"RT N","PXUTLS CC",97,0)  ;"RTN","PX UTLSCC",98 ,0) ;"RTN" ,"PXUTLSCC ",99,0)SCC OND(DFN,AP PDT,HLOC,V ISIT,PXUDA TA) ;Set u p array of  the patie nts"RTN"," PXUTLSCC", 100,0) ;   Service Co nnected Co nditions"R TN","PXUTL SCC",101,0 ) ;"RTN"," PXUTLSCC", 102,0) ;In put Parame ters:"RTN" ,"PXUTLSCC ",103,0) ;   DFN       IEN of pa tient"RTN" ,"PXUTLSCC ",104,0) ;   APPDT     date and  time of th e encounte r"RTN","PX UTLSCC",10 5,0) ;  HL OC     Hos pital Loca tion of th e enocunte r"RTN","PX UTLSCC",10 6,0) ;  VI SIT    (op tional) Th e visit th at is bein g used"RTN ","PXUTLSC C",107,0)  ;"RTN","PX UTLSCC",10 8,0) ;Outp ut Paramet ers:"RTN", "PXUTLSCC" ,109,0) ;   PXUDATA   this is an  array sub scripted b y "SC","AO ","IR","EC ","MST","H NC","CV"," SHAD","CLV ""RTN","PX UTLSCC",11 0,0) ;            tha t contains  2 pieces  each"RTN", "PXUTLSCC" ,111,0) ;     first:  1 if the c ondition c an be answ ered"RTN", "PXUTLSCC" ,112,0) ;             0 if it sh ould be nu ll"RTN","P XUTLSCC",1 13,0) ;    second: th e answer t hat Schedu ling has i f it has o ne"RTN","P XUTLSCC",1 14,0) ;            1  ::= yes,   0 ::= no"R TN","PXUTL SCC",115,0 ) ;"RTN"," PXUTLSCC", 116,0) N C LASSIF,XX, OUTENC,CL, END,X0,MNE "RTN","PXU TLSCC",117 ,0) S OUTE NC="""RTN" ,"PXUTLSCC ",118,0) I  VISIT>0 D "RTN","PXU TLSCC",119 ,0) .S OUT ENC=$O(^SC E("AVSIT", VISIT,0))" RTN","PXUT LSCC",120, 0) .I OUTE NC>0,$P(^S CE(OUTENC, 0),U,6) S  OUTENC=$P( ^SCE(OUTEN C,0),U,6)" RTN","PXUT LSCC",121, 0) I 'VISI T D"RTN"," PXUTLSCC", 122,0) .;  Call if th ey have an  appointme nt for thi s hospital  location" RTN","PXUT LSCC",123, 0) .; and  there is a n Outpatie nt Encount er IEN;"RT N","PXUTLS CC",124,0)  .; return s the answ er that sc heduling h as if any" RTN","PXUT LSCC",125, 0) .I $G(^ DPT(DFN,"S ",APPDT,0) )]"" S XX= $G(^(0)) I  +XX=HLOC  D"RTN","PX UTLSCC",12 6,0) ..S O UTENC=$P(X X,U,20)"RT N","PXUTLS CC",127,0)  .Q:OUTENC "RTN","PXU TLSCC",128 ,0) .;"RTN ","PXUTLSC C",129,0)  .; Find an  Outpatien t encouter  matching  DFN APPDT, HLOC if an y."RTN","P XUTLSCC",1 30,0) .S O UTENC=$$EX AE^SDOE(DF N,APPDT,AP PDT) D VER OUT"RTN"," PXUTLSCC", 131,0) ;"R TN","PXUTL SCC",132,0 ) ;Do Outp atient Enc ounter che cks"RTN"," PXUTLSCC", 133,0) I O UTENC D"RT N","PXUTLS CC",134,0)  .I '$D(^S CE(OUTENC, 0)) S OUTE NC="" Q"RT N","PXUTLS CC",135,0)  .S X0=^SC E(OUTENC,0 ),END=0 D  ENCHK(OUTE NC,X0)"RTN ","PXUTLSC C",136,0)  .I END S O UTENC="""R TN","PXUTL SCC",137,0 ) I OUTENC >0 D CLOE^ SDCO21(OUT ENC,.CLASS IF)"RTN"," PXUTLSCC", 138,0) ;"R TN","PXUTL SCC",139,0 ) I '$G(OU TENC) D CL ^SDCO21(DF N,APPDT,"" ,.CLASSIF) "RTN","PXU TLSCC",140 ,0) S XX=0 "RTN","PXU TLSCC",141 ,0) F  S X X=$O(^SD(4 09.41,XX))  Q:XX'>0   D"RTN","PX UTLSCC",14 2,0) .S MN E=$P($G(^S D(409.41,X X,0)),U,7)  I $D(MNE)  D"RTN","P XUTLSCC",1 43,0) ..S  PXUDATA(MN E)=$D(CLAS SIF(XX))_U _$P($G(CLA SSIF(XX)), U,2)"RTN", "PXUTLSCC" ,144,0) Q" RTN","PXUT LSCC",145, 0)ENCHK(EN COWNTR,X0)  ;Do outpa tient enco unter chec ks"RTN","P XUTLSCC",1 46,0) N LO C,ORG,DFN" RTN","PXUT LSCC",147, 0) S DFN=$ P(X0,U,2), LOC=$P(X0, U,4),ORG=$ P(X0,U,8)" RTN","PXUT LSCC",148, 0) I $$REQ ^SDM1A(+X0 )'="CO" S  END=1 Q  ; Check MAS  Check out  date param eter"RTN", "PXUTLSCC" ,149,0) I  ORG=1,'$$C LINIC^SDAM U(+LOC) S  END=1 Q  ; Screen for  valid cli nic"RTN"," PXUTLSCC", 150,0) I " ^1^2^"[("^ "_ORG_"^") ,$$INP^SDA M2(+DFN,+X 0)="I" S E ND=1 Q  ;I npat chk"R TN","PXUTL SCC",151,0 ) I $$EXOE ^SDCOU2(EN COWNTR) S  END=1 Q  ; Chk exempt  Outpt cla ssificatio n"RTN","PX UTLSCC",15 2,0) Q"RTN ","PXUTLSC C",153,0)V EROUT ;ver ify a clin ic"RTN","P XUTLSCC",1 54,0) Q:'O UTENC"RTN" ,"PXUTLSCC ",155,0) S  CL=$$GETO E^SDOE(OUT ENC) I $P( CL,U,4)'=H LOC S OUTE NC="""RTN" ,"PXUTLSCC ",156,0) Q "RTN","PXU TLSCC",157 ,0) ;"RTN" ,"VSITDEF" )0^39^B436 81458"RTN" ,"VSITDEF" ,1,0)VSITD EF ;ISL/de e - Defaul ting Logic  for the V isit ;4/17 /97"RTN"," VSITDEF",2 ,0) ;;1.0; PCE PATIEN T CARE ENC OUNTER;**7 6,111,130, 164,168,20 7**;Aug 12 , 1996;Bui ld 54"RTN" ,"VSITDEF" ,3,0) ; Pa tch PX*1*7 6 changes  the 2nd li ne of all  VSIT* rout ines to re flect"RTN" ,"VSITDEF" ,4,0) ; th e incorpor ation of t he module  into PCE.   For histo rical refe rence,"RTN ","VSITDEF ",5,0) ; t he old (VI SIT TRACKI NG) 2nd li ne is incl uded below  to refere nce VSIT"R TN","VSITD EF",6,0) ;  patches." RTN","VSIT DEF",7,0)  ;"RTN","VS ITDEF",8,0 ) ;;2.0;VI SIT TRACKI NG;**1,2** ;Aug 12, 1 996"RTN"," VSITDEF",9 ,0) ;"RTN" ,"VSITDEF" ,10,0) Q   ; - not an  entry poi nt"RTN","V SITDEF",11 ,0) ;"RTN" ,"VSITDEF" ,12,0)REQU IRED() ;Ch eck the re quired var iables"RTN ","VSITDEF ",13,0) ;a nd Default  all field s that are  need for  lookup mat ching"RTN" ,"VSITDEF" ,14,0) ; R eturns: 0  if no erro rs and "RT N","VSITDE F",15,0) ;            1 if there  are error s that pre vent proce ssing"RTN" ,"VSITDEF" ,16,0) ;           (s tored in Q UIT)"RTN", "VSITDEF", 17,0) N QU IT,SITE"RT N","VSITDE F",18,0) S  QUIT=0"RT N","VSITDE F",19,0) S  SITE=+$$S ITE^VASITE ($P($G(VSI T("VDT")), "^"))"RTN" ,"VSITDEF" ,20,0) ; -  VDT"RTN", "VSITDEF", 21,0) S VS IT("VDT")= $$ERRCHK^V SITCK("VDT ",VSIT("VD T"),$S(VSI T("SVC")=" E":"TS",1: ""))"RTN", "VSITDEF", 22,0) I $L (VSIT("VDT "),"^")>1  D ERR^VSIT PUT($P(VSI T("VDT")," ^",2,99))  S QUIT=1"R TN","VSITD EF",23,0)  ; - PAT"RT N","VSITDE F",24,0) S  VSIT("PAT ")=$$ERRCH K^VSITCK(" PAT",VSIT( "PAT"))"RT N","VSITDE F",25,0) I  $L(VSIT(" PAT"),"^") >1 D ERR^V SITPUT($P( VSIT("PAT" ),"^",2,99 )) S QUIT= 1"RTN","VS ITDEF",26, 0) I VSIT( "INS")="", VSIT("OUT" )="",VSIT( "SVC")'="E " D"RTN"," VSITDEF",2 7,0) . S V SIT("INS") =$$INS4LOC ^VSITCK1(+ VSIT("LOC" ))"RTN","V SITDEF",28 ,0) . I VS IT("INS")' ]"",SITE>0  S VSIT("I NS")=SITE" RTN","VSIT DEF",29,0)  . S VSIT( "INS")=$$E RRCHK^VSIT CK("INS",V SIT("INS") )"RTN","VS ITDEF",30, 0) I $L(VS IT("INS"), "^")>1 D E RR^VSITPUT ($P(VSIT(" INS"),"^", 2,99)) S Q UIT=1"RTN" ,"VSITDEF" ,31,0) ; -  LOC"RTN", "VSITDEF", 32,0) I (V SIT("INS") =SITE&(VSI T("SVC")'= "E"))!(VSI T("LOC")]" ") D"RTN", "VSITDEF", 33,0) . S  VSIT("LOC" )=$$ERRCHK ^VSITCK("L OC",VSIT(" LOC"))"RTN ","VSITDEF ",34,0) I  $L(VSIT("L OC"),"^")> 1 D ERR^VS ITPUT($P(V SIT("LOC") ,"^",2,99) ) S QUIT=1 "RTN","VSI TDEF",35,0 ) ; - TYP" RTN","VSIT DEF",36,0)  I VSIT("T YP")']"",V SIT("INS") ]"" S VSIT ("TYP")="V ""RTN","VS ITDEF",37, 0) I VSIT( "TYP")']"" ,VSIT("SVC ")="E" S V SIT("TYP") ="O""RTN", "VSITDEF", 38,0) S:VS IT("TYP")' ]"" VSIT(" TYP")=$G(D UZ("AG"))" RTN","VSIT DEF",39,0)  S:VSIT("T YP")']"" V SIT("TYP") =$P($G(^DI C(150.9,1, 0)),"^",3) "RTN","VSI TDEF",40,0 ) S VSIT(" TYP")=$$ER RCHK^VSITC K("TYP",VS IT("TYP")) "RTN","VSI TDEF",41,0 ) I $L(VSI T("TYP")," ^")>1 D ER R^VSITPUT( $P(VSIT("T YP"),"^",2 ,99)) S QU IT=1"RTN", "VSITDEF", 42,0) ; -  DSS"RTN"," VSITDEF",4 3,0) I VSI T("DSS")=" ",VSIT("LO C")]"" D"R TN","VSITD EF",44,0)  . S VSIT(" DSS")=$$DS S4LOC^VSIT CK1(+VSIT( "LOC"))"RT N","VSITDE F",45,0) I  VSIT("DSS ")]"" D"RT N","VSITDE F",46,0) .  S VSIT("D SS")=$$ERR CHK^VSITCK ("DSS",VSI T("DSS"))" RTN","VSIT DEF",47,0)  I $L(VSIT ("DSS"),"^ ")>1 D ERR ^VSITPUT($ P(VSIT("DS S"),"^",2, 99)) S QUI T=1"RTN"," VSITDEF",4 8,0) ; - I O"RTN","VS ITDEF",49, 0) S VSIT( "IO")=$S(V SITIPM>0:1 ,1:0)"RTN" ,"VSITDEF" ,50,0) ; -  SVC"RTN", "VSITDEF", 51,0) I VS IT("SVC")' ="E" D"RTN ","VSITDEF ",52,0) .  I +VSIT("D SS") D"RTN ","VSITDEF ",53,0) ..  ;Default  svc based  on the dss  id"RTN"," VSITDEF",5 4,0) .. I  $P(^DIC(40 .7,+VSIT(" DSS"),0)," ^",1)["TEL E" S VSIT( "SVC")="T"  ;any TELE phone"RTN" ,"VSITDEF" ,55,0) ..  E  I $O(^V SIT(150.1, "B",+$P(^D IC(40.7,+V SIT("DSS") ,0),"^",2) ,0)) S VSI T("SVC")=" X""RTN","V SITDEF",56 ,0) .. E   I VSIT("SV C")="",VSI T("DSS")=$ P($G(^SC(+ VSIT("LOC" ),0)),"^", 7) S VSIT( "SVC")="A" "RTN","VSI TDEF",57,0 ) . I VSIT ("SVC")=""  S VSIT("S VC")="X""R TN","VSITD EF",58,0)  I VSIT("IO ") D"RTN", "VSITDEF", 59,0) . I  VSIT("SVC" )="A" S VS IT("SVC")= "I""RTN"," VSITDEF",6 0,0) . E   I VSIT("SV C")="X" S  VSIT("SVC" )="D""RTN" ,"VSITDEF" ,61,0) E   D"RTN","VS ITDEF",62, 0) . I VSI T("SVC")=" I" S VSIT( "SVC")="A" "RTN","VSI TDEF",63,0 ) . E  I V SIT("SVC") ="D" S VSI T("SVC")=" X""RTN","V SITDEF",64 ,0) S VSIT ("SVC")=$$ ERRCHK^VSI TCK("SVC", VSIT("SVC" ))"RTN","V SITDEF",65 ,0) I $L(V SIT("SVC") ,"^")>1 D  ERR^VSITPU T($P(VSIT( "SVC"),"^" ,2,99)) S  QUIT=1"RTN ","VSITDEF ",66,0) ;" RTN","VSIT DEF",67,0)  Q QUIT"RT N","VSITDE F",68,0) ; "RTN","VSI TDEF",69,0 )DEFAULTS  ;Default a ll of the  rest of th e fields t hat are NO T need for  lookup ma tching"RTN ","VSITDEF ",70,0) ;  - CDT & MD T"RTN","VS ITDEF",71, 0) D"RTN", "VSITDEF", 72,0) . N  %,%H,%I,X" RTN","VSIT DEF",73,0)  . D NOW^% DTC"RTN"," VSITDEF",7 4,0) . S ( VSIT("CDT" ),VSIT("MD T"))=%"RTN ","VSITDEF ",75,0) ;  - LNK"RTN" ,"VSITDEF" ,76,0) ;    check if  good"RTN", "VSITDEF", 77,0) D:VS IT("LNK")] """RTN","V SITDEF",78 ,0) . S VS IT("LNK")= $$GET^VSIT VAR("LNK", VSIT("LNK" ))"RTN","V SITDEF",79 ,0) . I +V SIT("LNK") ,+VSIT("PA T") D"RTN" ,"VSITDEF" ,80,0) . .  S NOD=$G( ^AUPNVSIT( +VSIT("LNK "),0))"RTN ","VSITDEF ",81,0) .  . S:+$P(NO D,"^",11)  VSIT("LNK" )="" ; del ete flag"R TN","VSITD EF",82,0)  . . S:+VSI T("PAT")'= $P(NOD,"^" ,5) VSIT(" LNK")="" ;  different  patients" RTN","VSIT DEF",83,0)  S VSIT("L NK")=$$ERR CHK^VSITCK ("LNK",VSI T("LNK"))" RTN","VSIT DEF",84,0)  D:$L(VSIT ("LNK"),"^ ")>1 WRN^V SITPUT($P( VSIT("LNK" ),"^",2,99 ))"RTN","V SITDEF",85 ,0) ; - CO D"RTN","VS ITDEF",86, 0) S VSIT( "COD")=$$E RRCHK^VSIT CK("COD",V SIT("COD") )"RTN","VS ITDEF",87, 0) D:$L(VS IT("COD"), "^")>1 WRN ^VSITPUT($ P(VSIT("CO D"),"^",2, 99))"RTN", "VSITDEF", 88,0) ; -  ELG"RTN"," VSITDEF",8 9,0) I +VS IT("PAT"), $F(VSIT(0) ,"I")!($F( VSIT(0),"E ")) D"RTN" ,"VSITDEF" ,90,0) . S :VSIT(0)[" I" VSIT("E LG")=$$ELG ^VSITASK(V SIT("PAT") )"RTN","VS ITDEF",91, 0) . D:VSI T("ELG")=" ""RTN","VS ITDEF",92, 0) . . S:V SIT("LNK") >0 VSIT("E LG")=$P($G (^AUPNVSIT (VSIT("LNK "),0)),"^" ,21) ;Elig ibility Co de form Pa rent Visit "RTN","VSI TDEF",93,0 ) . . S:VS IT("ELG")= "" VSIT("E LG")=$P($G (^DPT(+VSI T("PAT"),. 36)),"^")  ;Primary E ligibility  Code"RTN" ,"VSITDEF" ,94,0) . .  D:VSIT("E LG")="""RT N","VSITDE F",95,0) .  . . N VSI TI,VSITE"R TN","VSITD EF",96,0)  . . . S (V SITI,VSITE )=0"RTN"," VSITDEF",9 7,0) . . .  ;See if a ny eligibi lities it  the Patien t Eigibili ties sub-f ile"RTN"," VSITDEF",9 8,0) . . .  F  S VSIT E=$O(^DPT( +VSIT("PAT "),"E",VSI TE)) Q:VSI TE'>0  S V SITI=VSITI +1"RTN","V SITDEF",99 ,0) . . .  I VSITI=1  S VSIT("EL G")=$O(^DP T(+VSIT("P AT"),"E",0 )) ;If onl y one use  it"RTN","V SITDEF",10 0,0) S VSI T("ELG")=$ $ERRCHK^VS ITCK("ELG" ,VSIT("ELG "))"RTN"," VSITDEF",1 01,0) D:$L (VSIT("ELG "),"^")>1  WRN^VSITPU T($P(VSIT( "ELG"),"^" ,2,99))"RT N","VSITDE F",102,0)  ; - USR"RT N","VSITDE F",103,0)  I VSIT("US R")="",+$G (DUZ) S VS IT("USR")= +DUZ"RTN", "VSITDEF", 104,0) S V SIT("USR") =$$ERRCHK^ VSITCK("US R",VSIT("U SR"))"RTN" ,"VSITDEF" ,105,0) D: $L(VSIT("U SR"),"^")> 1 WRN^VSIT PUT($P(VSI T("USR")," ^",2,99))" RTN","VSIT DEF",106,0 ) ; - OPT" RTN","VSIT DEF",107,0 ) S:VSIT(" OPT")="" V SIT("OPT") =$P($G(XQY ),"^")"RTN ","VSITDEF ",108,0) S  VSIT("OPT ")=$$ERRCH K^VSITCK(" OPT",VSIT( "OPT"))"RT N","VSITDE F",109,0)  D:$L(VSIT( "OPT"),"^" )>1 WRN^VS ITPUT($P(V SIT("OPT") ,"^",2,99) )"RTN","VS ITDEF",110 ,0) ; - PR O"RTN","VS ITDEF",111 ,0) I VSIT ("PRO")="" ,$P($G(XQO RNOD),";", 2)="ORD(10 1," S VSIT ("PRO")=$P ($G(XQORNO D),";")"RT N","VSITDE F",112,0)  S VSIT("PR O")=$$ERRC HK^VSITCK( "PRO",VSIT ("PRO"))"R TN","VSITD EF",113,0)  D:$L(VSIT ("PRO"),"^ ")>1 WRN^V SITPUT($P( VSIT("PRO" ),"^",2,99 ))"RTN","V SITDEF",11 4,0) ; - O UT"RTN","V SITDEF",11 5,0) S VSI T("OUT")=$ $ERRCHK^VS ITCK("OUT" ,VSIT("OUT "))"RTN"," VSITDEF",1 16,0) D:$L (VSIT("OUT "),"^")>1  WRN^VSITPU T($P(VSIT( "OUT"),"^" ,2,99))"RT N","VSITDE F",117,0)  ; - VID"RT N","VSITDE F",118,0)  S VSIT("VI D")=$$GETV ID^VSITVID "RTN","VSI TDEF",119, 0) ; - PRI "RTN","VSI TDEF",120, 0) I VSIT( "PRI")="P" ,$O(^VSIT( 150.1,"B", +$P($G(^DI C(40.7,+VS IT("DSS"), 0)),"^",2) ,0)) S VSI T("PRI")=" O""RTN","V SITDEF",12 1,0) S VSI T("PRI")=$ $ERRCHK^VS ITCK("PRI" ,VSIT("PRI "))"RTN"," VSITDEF",1 22,0) D:$L (VSIT("PRI "),"^")>1  WRN^VSITPU T($P(VSIT( "PRI"),"^" ,2,99))"RT N","VSITDE F",123,0)  ; - SC"RTN ","VSITDEF ",124,0) S  VSIT("SC" )=$$ERRCHK ^VSITCK("S C",VSIT("S C"))"RTN", "VSITDEF", 125,0) D:$ L(VSIT("SC "),"^")>1  WRN^VSITPU T($P(VSIT( "SC"),"^", 2,99))"RTN ","VSITDEF ",126,0) ;  - AO"RTN" ,"VSITDEF" ,127,0) S  VSIT("AO") =$$ERRCHK^ VSITCK("AO ",VSIT("AO "))"RTN"," VSITDEF",1 28,0) D:$L (VSIT("AO" ),"^")>1 W RN^VSITPUT ($P(VSIT(" AO"),"^",2 ,99))"RTN" ,"VSITDEF" ,129,0) ;  - IR"RTN", "VSITDEF", 130,0) S V SIT("IR")= $$ERRCHK^V SITCK("IR" ,VSIT("IR" ))"RTN","V SITDEF",13 1,0) D:$L( VSIT("IR") ,"^")>1 WR N^VSITPUT( $P(VSIT("I R"),"^",2, 99))"RTN", "VSITDEF", 132,0) ; -  EC"RTN"," VSITDEF",1 33,0) S VS IT("EC")=$ $ERRCHK^VS ITCK("EC", VSIT("EC") )"RTN","VS ITDEF",134 ,0) D:$L(V SIT("EC"), "^")>1 WRN ^VSITPUT($ P(VSIT("EC "),"^",2,9 9))"RTN"," VSITDEF",1 35,0) ; -  HNC - PX*1 *111 - Hea d & Neck"R TN","VSITD EF",136,0)  S VSIT("H NC")=$$ERR CHK^VSITCK ("HNC",VSI T("HNC"))" RTN","VSIT DEF",137,0 ) D:$L(VSI T("HNC")," ^")>1 WRN^ VSITPUT($P (VSIT("HNC "),"^",2,9 9))"RTN"," VSITDEF",1 38,0) ; -  CV - PX*1* 130 - Comb at Vet"RTN ","VSITDEF ",139,0) S  VSIT("CV" )=$$ERRCHK ^VSITCK("C V",VSIT("C V"))"RTN", "VSITDEF", 140,0) D:$ L(VSIT("CV "),"^")>1  WRN^VSITPU T($P(VSIT( "CV"),"^", 2,99))"RTN ","VSITDEF ",141,0) ;  - SHAD -  PX*1*168 -  Project 1 12/SHAD"RT N","VSITDE F",142,0)  S VSIT("SH AD")=$$ERR CHK^VSITCK ("SHAD",VS IT("SHAD") )"RTN","VS ITDEF",143 ,0) D:$L(V SIT("SHAD" ),"^")>1 W RN^VSITPUT ($P(VSIT(" SHAD"),"^" ,2,99))"RT N","VSITDE F",144,0)  ; - CLV -  PX*1.0*207  - Camp Le jeune - dj s  RSD SPE C #2.6.2.1 .1"RTN","V SITDEF",14 5,0) S VSI T("CLV")=$ $ERRCHK^VS ITCK("CLV" ,VSIT("CLV "))"RTN"," VSITDEF",1 46,0) D:$L (VSIT("CLV "),"^")>1  WRN^VSITPU T($P(VSIT( "CLV"),"^" ,2,99))"RT N","VSITDE F",147,0)  ; - COM"RT N","VSITDE F",148,0)  S VSIT("CO M")=$$ERRC HK^VSITCK( "COM",VSIT ("COM"))"R TN","VSITD EF",149,0)  D:$L(VSIT ("COM"),"^ ")>1 WRN^V SITPUT($P( VSIT("COM" ),"^",2,99 ))"RTN","V SITDEF",15 0,0) ; - V ER"RTN","V SITDEF",15 1,0) S VSI T("VER")=$ $ERRCHK^VS ITCK("VER" ,VSIT("VER "))"RTN"," VSITDEF",1 52,0) D:$L (VSIT("VER "),"^")>1  WRN^VSITPU T($P(VSIT( "VER"),"^" ,2,99))"RT N","VSITDE F",153,0)  ; - PKG"RT N","VSITDE F",154,0)  S VSIT("PK G")=$$PKG2 IEN^VSIT(V SIT("PKG") )"RTN","VS ITDEF",155 ,0) S VSIT ("PKG")=$$ ERRCHK^VSI TCK("PKG", VSIT("PKG" ))"RTN","V SITDEF",15 6,0) D:$L( VSIT("PKG" ),"^")>1 W RN^VSITPUT ($P(VSIT(" PKG"),"^", 2,99))"RTN ","VSITDEF ",157,0) ;  - SOR"RTN ","VSITDEF ",158,0) ; Lookup sou rce in PCE  DATA SOUR CE file (# 839.7) wit h LAYGO"RT N","VSITDE F",159,0)  I VSIT("SO R")'=+VSIT ("SOR") D" RTN","VSIT DEF",160,0 ) . I $T(S OURCE^PXAP I)="" D"RT N","VSITDE F",161,0)  .. S VSIT( "SOR")=$$S OURCE^PXAP I(VSIT("SO R"))"RTN", "VSITDEF", 162,0) . E   S VSIT(" SOR")="""R TN","VSITD EF",163,0)  S VSIT("S OR")=$$ERR CHK^VSITCK ("SOR",VSI T("SOR"))" RTN","VSIT DEF",164,0 ) D:$L(VSI T("SOR")," ^")>1 WRN^ VSITPUT($P (VSIT("SOR "),"^",2,9 9))"RTN"," VSITDEF",1 65,0) ;"RT N","VSITDE F",166,0)  ;PFSS Pati ent Refere nce"RTN"," VSITDEF",1 67,0) S VS IT("ACT")= $$ERRCHK^V SITCK("ACT ",VSIT("AC T"))"RTN", "VSITDEF", 168,0) I $ $SWSTAT^IB BAPI() D:$ L(VSIT("AC T"),"^")>1  WRN^VSITP UT($P(VSIT ("ACT"),"^ ",2,99))"R TN","VSITD EF",169,0)  Q"RTN","V SITDEF",17 0,0) ;"RTN ","VSITFLD ")0^40^B11 718232"RTN ","VSITFLD ",1,0)VSIT FLD ;ISD/M RL,RJP - V isit Track ing file f ields arra y setup ;6 /20/96"RTN ","VSITFLD ",2,0) ;;1 .0;PCE PAT IENT CARE  ENCOUNTER; **76,81,11 1,130,124, 164,168,20 7**;Aug 12 , 1996;Bui ld 54"RTN" ,"VSITFLD" ,3,0) ; Pa tch PX*1*7 6 changes  the 2nd li ne of all  VSIT* rout ines to re flect"RTN" ,"VSITFLD" ,4,0) ; th e incorpor ation of t he module  into PCE.   For histo rical refe rence,"RTN ","VSITFLD ",5,0) ; t he old (VI SIT TRACKI NG) 2nd li ne is incl uded below  to refere nce VSIT"R TN","VSITF LD",6,0) ;  patches." RTN","VSIT FLD",7,0)  ;"RTN","VS ITFLD",8,0 ) ;;2.0;VI SIT TRACKI NG;**4**;A ug 12, 199 6;"RTN","V SITFLD",9, 0) ;"RTN", "VSITFLD", 10,0) Q"RT N","VSITFL D",11,0) ; "RTN","VSI TFLD",12,0 )FLD ; - V isit file  fields; ar ray subscr ipt and fi eld DD num ber fmt"RT N","VSITFL D",13,0) ;    <visit  subscript> ;<field#>; <node>;<pi ece>;<erro r message> "RTN","VSI TFLD",14,0 ) ;"RTN"," VSITFLD",1 5,0) S ^TM P("VSITDD" ,$J,"VDT") ="VDT;.01; 0;1;Invali d Encounte r/Admit Da te&Time [0 ;1]""RTN", "VSITFLD", 16,0) S ^T MP("VSITDD ",$J,"CDT" )="CDT;.02 ;0;2""RTN" ,"VSITFLD" ,17,0) S ^ TMP("VSITD D",$J,"TYP ")="TYP;.0 3;0;3;Inva lid Type [ 0:3]""RTN" ,"VSITFLD" ,18,0) S ^ TMP("VSITD D",$J,"PAT ")="PAT;.0 5;0;5;Inva lid Patien t [0:5]""R TN","VSITF LD",19,0)  S ^TMP("VS ITDD",$J," INS")="INS ;.06;0;6;I nvalid Loc  of Encoun ter [0:6]" "RTN","VSI TFLD",20,0 ) S ^TMP(" VSITDD",$J ,"SVC")="S VC;.07;0;7 ;Invalid S ervice Cat egory [0:7 ]""RTN","V SITFLD",21 ,0) S ^TMP ("VSITDD", $J,"DSS")= "DSS;.08;0 ;8;Invalid  DSS ID [0 :8]""RTN", "VSITFLD", 22,0) S ^T MP("VSITDD ",$J,"CTR" )="CTR;.09 ;0;9""RTN" ,"VSITFLD" ,23,0) S ^ TMP("VSITD D",$J,"DEL ")="DEL;.1 1;0;11""RT N","VSITFL D",24,0) S  ^TMP("VSI TDD",$J,"L NK")="LNK; .12;0;12"" RTN","VSIT FLD",25,0)  S ^TMP("V SITDD",$J, "MDT")="MD T;.13;0;13 ""RTN","VS ITFLD",26, 0) S ^TMP( "VSITDD",$ J,"COD")=" COD;.18;0; 18""RTN"," VSITFLD",2 7,0) S ^TM P("VSITDD" ,$J,"ELG") ="ELG;.21; 0;21;Inval id Eligibi lity [0:21 ]""RTN","V SITFLD",28 ,0) S ^TMP ("VSITDD", $J,"LOC")= "LOC;.22;0 ;22;Invali d Hospital  Location  [0:22] - T he specifi ed Hospita l Location  was not f ound defin ed in the  Hospital L ocation fi le.""RTN", "VSITFLD", 29,0) S ^T MP("VSITDD ",$J,"USR" )="USR;.23 ;0;23;Inva lid Create d by User  [0:23]""RT N","VSITFL D",30,0) S  ^TMP("VSI TDD",$J,"O PT")="OPT; .24;0;24"" RTN","VSIT FLD",31,0)  S ^TMP("V SITDD",$J, "PRO")="PR O;.25;0;25 ""RTN","VS ITFLD",32, 0) S ^TMP( "VSITDD",$ J,"ACT")=" ACT;.26;0; 26""RTN"," VSITFLD",3 3,0) S ^TM P("VSITDD" ,$J,"OUT") ="OUT;2101 ;21;1""RTN ","VSITFLD ",34,0) S  ^TMP("VSIT DD",$J,"VI D")="VID;1 5001;150;1 ""RTN","VS ITFLD",35, 0) S ^TMP( "VSITDD",$ J,"IO")="I O;15002;15 0;2""RTN", "VSITFLD", 36,0) S ^T MP("VSITDD ",$J,"PRI" )="PRI;150 03;150;3"" RTN","VSIT FLD",37,0)  S ^TMP("V SITDD",$J, "SC")="SC; 80001;800; 1""RTN","V SITFLD",38 ,0) S ^TMP ("VSITDD", $J,"AO")=" AO;80002;8 00;2""RTN" ,"VSITFLD" ,39,0) S ^ TMP("VSITD D",$J,"IR" )="IR;8000 3;800;3""R TN","VSITF LD",40,0)  S ^TMP("VS ITDD",$J," EC")="EC;8 0004;800;4 ""RTN","VS ITFLD",41, 0) S ^TMP( "VSITDD",$ J,"MST")=" MST;80005; 800;5" ;ad ded 6/17/9 8 for MST  enhancemen t"RTN","VS ITFLD",42, 0) S ^TMP( "VSITDD",$ J,"HNC")=" HNC;80006; 800;6" ;PX *1*111 add ed for HNC  enhanceme nt"RTN","V SITFLD",43 ,0) S ^TMP ("VSITDD", $J,"CV")=" CV;80007;8 00;7" ;PX* 1*130 Comb at Veteran "RTN","VSI TFLD",44,0 ) S ^TMP(" VSITDD",$J ,"SHAD")=" SHAD;80008 ;800;8" ;P X*1*168 Pr oject 112/ SHAD"RTN", "VSITFLD", 45,0) ;  d js  PX*1.0 *207  RSD  SPEC #2.6. 2.1.1 & 2. 6.2.1.2  A dded for C amp Lejeun e enhancem ent"RTN"," VSITFLD",4 6,0) S ^TM P("VSITDD" ,$J,"CLV") ="CLV;8000 9;800;9""R TN","VSITF LD",47,0)  S ^TMP("VS ITDD",$J," SCEF")="SC ED;80011;8 00;11" ;PX *1*124 SC  EDIT FLAG" RTN","VSIT FLD",48,0)  S ^TMP("V SITDD",$J, "AOEF")="A OED;80012; 800;12" ;P X*1*124 AO  EDIT FLAG "RTN","VSI TFLD",49,0 ) S ^TMP(" VSITDD",$J ,"IREF")=" IRED;80013 ;800;13" ; PX*1*124 I R EDIT FLA G"RTN","VS ITFLD",50, 0) S ^TMP( "VSITDD",$ J,"ECEF")= "ECED;8001 4;800;14"  ;PX*1*124  EC EDIT FL AG"RTN","V SITFLD",51 ,0) S ^TMP ("VSITDD", $J,"MSTEF" )="MSTED;8 0015;800;1 5" ;PX*1*1 24 MST EDI T FLAG"RTN ","VSITFLD ",52,0) S  ^TMP("VSIT DD",$J,"HN CEF")="HNC ED;80016;8 00;16" ;PX *1*124 HNC  EDIT FLAG "RTN","VSI TFLD",53,0 ) S ^TMP(" VSITDD",$J ,"CVEF")=" CVED;80017 ;800;17" ; PX*1*124 C V EDIT FLA G"RTN","VS ITFLD",54, 0) S ^TMP( "VSITDD",$ J,"SHADEF" )="SHADED; 80018;800; 18" ;PX*1* 168 SHAD E DIT FLAG"R TN","VSITF LD",55,0)  ;  djs  PX *1.0*207   RSD SPEC # 2.6.2.1.1  & 2.6.2.1. 2  CAMP LE JEUNE EDIT  FLAG"RTN" ,"VSITFLD" ,56,0) S ^ TMP("VSITD D",$J,"CLV EF")="CLVE D;80019;80 0;19""RTN" ,"VSITFLD" ,57,0) S ^ TMP("VSITD D",$J,"COM ")="COM;81 101;811;1" "RTN","VSI TFLD",58,0 ) S ^TMP(" VSITDD",$J ,"VER")="V ER;81201;8 12;1""RTN" ,"VSITFLD" ,59,0) S ^ TMP("VSITD D",$J,"PKG ")="PKG;81 202;812;2" "RTN","VSI TFLD",60,0 ) S ^TMP(" VSITDD",$J ,"SOR")="S OR;81203;8 12;3""RTN" ,"VSITFLD" ,61,0) Q"R TN","VSITF LD",62,0)  ;"RTN","VS ITHLP")0^4 1^B1877197 5"RTN","VS ITHLP",1,0 )VSITHLP ; ISD/RJP -  Visit Info rmation ;6 /6/05"RTN" ,"VSITHLP" ,2,0) ;;1. 0;PCE PATI ENT CARE E NCOUNTER;* *76,111,13 0,168,207* *;Aug 12,  1996;Build  54"RTN"," VSITHLP",3 ,0) ; Patc h PX*1*76  changes th e 2nd line  of all VS IT* routin es to refl ect"RTN"," VSITHLP",4 ,0) ; the  incorporat ion of the  module in to PCE.  F or histori cal refere nce,"RTN", "VSITHLP", 5,0) ; the  old (VISI T TRACKING ) 2nd line  is includ ed below t o referenc e VSIT"RTN ","VSITHLP ",6,0) ; p atches."RT N","VSITHL P",7,0) ;" RTN","VSIT HLP",8,0)  ;;2.0;VISI T TRACKING ;;Aug 12,  1996;"RTN" ,"VSITHLP" ,9,0) ;"RT N","VSITHL P",10,0) N  TXT,DIR,D X,DY,VSITI ,X"RTN","V SITHLP",11 ,0) I '$D( IOSL) S IO P=0 D ^%ZI S K IOP"RT N","VSITHL P",12,0) D  HOME^%ZIS  W @IOF"RT N","VSITHL P",13,0) F  VSITI=1:1  S TXT=$T( TXT+VSITI)  Q:TXT=""   D"RTN","V SITHLP",14 ,0) . W $P (TXT,";;", 2)"RTN","V SITHLP",15 ,0) . I $Y >(IOSL-3)  D"RTN","VS ITHLP",16, 0) . . S D IR(0)="E"  D ^DIR"RTN ","VSITHLP ",17,0) .  . N X S $P (X," ",79) ="" W $C(1 3),X,$C(13 )"RTN","VS ITHLP",18, 0) . . S ( DX,DY)=0 X  ^%ZOSF("X Y")"RTN"," VSITHLP",1 9,0) . E   W !"RTN"," VSITHLP",2 0,0) Q"RTN ","VSITHLP ",21,0) ;" RTN","VSIT HLP",22,0) TXT ;"RTN" ,"VSITHLP" ,23,0) ;;  VSIT(0)    A string o f characte rs which d efines how  the visit "RTN","VSI THLP",24,0 ) ;;            proce ssor will  function." RTN","VSIT HLP",25,0)  ;;"RTN"," VSITHLP",2 6,0) ;;            F  - Force ad ding a new  entry."RT N","VSITHL P",27,0) ; ;            I - Inte ractive mo de."RTN"," VSITHLP",2 8,0) ;;            E  - Use pt's  primary e ligibility  if now pa ssed on"RT N","VSITHL P",29,0) ; ;                call  w/ VSIT(" ELG")."RTN ","VSITHLP ",30,0) ;;             N - Allow  creation  of a new v isit."RTN" ,"VSITHLP" ,31,0) ;;             D - Look b ack "n" nu mber of da ys for a m atch, defa ult"RTN"," VSITHLP",3 2,0) ;;                 is one ( 1).   e.g.  VSIT(0)=" D5"  (v/dt  to v/dt-4 )"RTN","VS ITHLP",33, 0) ;;                 Use "D0" t o require  exact matc h on date  & time."RT N","VSITHL P",34,0) ; ;            M - Impo se criteri a on match ing or cre ation of v isits."RTN ","VSITHLP ",35,0) ;;                 Uses  the VSIT(< xxx>) arra y:"RTN","V SITHLP",36 ,0) ;                    [<fld-v alue>[^... ]] for mul tiple valu es"RTN","V SITHLP",37 ,0) ;;                 - If tryi ng to matc h with exi sting visi t, each el ement"RTN" ,"VSITHLP" ,38,0) ;;                   must  match eac h correspo nding fiel d."RTN","V SITHLP",39 ,0) ;;"RTN ","VSITHLP ",40,0) ;;  Variable  names for  VISIT file  fields:   #9000010    gbl:  ^AU PNVSIT("RT N","VSITHL P",41,0) ; ;          (format) - >   <inter nal format >[^<extern al format> ]"RTN","VS ITHLP",42, 0) ;;            exce pt VSIT(<i en>) = N^S [^1]"RTN", "VSITHLP", 43,0) ;;                         where N =  internal e ntry numbe r"RTN","VS ITHLP",44, 0) ;;                               S = val ue of .01  filed"RTN" ,"VSITHLP" ,45,0) ;;                               1 =  indicated  new entry  added"RTN ","VSITHLP ",46,0) ;;   .001 - V SIT("IEN")  ; NUMBER  (internal  entry numb er)"RTN"," VSITHLP",4 7,0) ;;    .01 - VSIT ("VDT") ;  VISIT/ADMI T DATE&TIM E (date)"R TN","VSITH LP",48,0)  ;;   .02 -  VSIT("CDT ") ; DATE  VISIT CREA TED (date) "RTN","VSI THLP",49,0 ) ;;   .03  - VSIT("T YP") ; TYP E (set)"RT N","VSITHL P",50,0) ; ;   .05 -  VSIT("PAT" ) ; PATIEN T (pointer  to PATIEN T file #90 00001)"RTN ","VSITHLP ",51,0) ;;                          (IHS fi le DINUM'e d to PATIE NT file #2 )"RTN","VS ITHLP",52, 0) ;;   .0 6 - VSIT(" INS") ; LO C. OF ENCO UNTER (poi nter to LO CATION fil e"RTN","VS ITHLP",53, 0) ;;                         #9 999999.06) "RTN","VSI THLP",54,0 ) ;;                         (IH S file DIN UM'ed to I NSTITUTION  file #4)" RTN","VSIT HLP",55,0)  ;;   .07  - VSIT("SV C") ; SERV ICE CATEGO RY (set)"R TN","VSITH LP",56,0)  ;;   .08 -  VSIT("DSS ") ; CLINI C (pointer  to CLINIC  STOP file  #40.7)"RT N","VSITHL P",57,0) ; ;   .09 -  VSIT("CTR" ) ; DEPEND ENT ENTRY  COUNTER (n umber)"RTN ","VSITHLP ",58,0) ;;    .11 - V SIT("DEL")  ; DELETE  FLAG (set) "RTN","VSI THLP",59,0 ) ;;   .12  - VSIT("L NK") ; PAR ENT VISIT  LINK (poin ter to VIS IT file)"R TN","VSITH LP",60,0)  ;;   .13 -  VSIT("MDT ") ; DATE  LAST MODIF IED (date) "RTN","VSI THLP",61,0 ) ;;   .18  - VSIT("C OD") ; CHE CK OUT DAT E&TIME (da te)"RTN"," VSITHLP",6 2,0) ;;    .21 - VSIT ("ELG") ;  ELIGIBILIT Y (pointer  to ELIGIB ILITY CODE "RTN","VSI THLP",63,0 ) ;;                         fil e #8)"RTN" ,"VSITHLP" ,64,0) ;;    .22 - VS IT("LOC")  ; HOSPITAL  LOCATION  (pointer t o HOSPITAL "RTN","VSI THLP",65,0 ) ;;                         LOC ATION file  #44)"RTN" ,"VSITHLP" ,66,0) ;;    .23 - VS IT("USR")  ; CREATED  BY USER (p ointer to  USER file  #200)"RTN" ,"VSITHLP" ,67,0) ;;    .24 - VS IT("OPT")  ; OPTION U SED TO CRE ATE (point er to OPTI ON"RTN","V SITHLP",68 ,0) ;;                         f ile #19)"R TN","VSITH LP",69,0)  ;;   .25 -  VSIT("PRO ") ; PROTO COL (point er to PROT OCOL file  #101)"RTN" ,"VSITHLP" ,70,0) ;;   2101 - VS IT("OUT")  ; OUTSIDE  LOCATION ( free text) "RTN","VSI THLP",71,0 ) ;; 15001  - VSIT("V ID") ; VIS IT ID (fre e text)"RT N","VSITHL P",72,0) ; ; 15002 -  VSIT("IO")   ; PATIEN T STATUS I N/OUT (set )"RTN","VS ITHLP",73, 0) ;; 1500 3 - VSIT(" PRI") ; EN COUNTER TY PE (set)"R TN","VSITH LP",74,0)  ;; 80001 -  VSIT("SC" )  ; SERVI CE CONNECT ED (set)"R TN","VSITH LP",75,0)  ;; 80002 -  VSIT("AO" )  ; AGENT  ORANGE EX POSURE (se t)"RTN","V SITHLP",76 ,0) ;; 800 03 - VSIT( "IR")  ; I ONIZING RA DIATION EX POSURE (se t)"RTN","V SITHLP",77 ,0) ;; 800 04 - VSIT( "EC")  ; P ERSIAN GUL F EXPOSURE  (set)"RTN ","VSITHLP ",78,0) ;;  80006 - V SIT("HNC")  ; HEAD AN D/OR NECK  CANCER (se t)"RTN","V SITHLP",79 ,0) ;; 800 07 - VSIT( "CV")  ; C OMBAT VET  (set)"RTN" ,"VSITHLP" ,80,0) ;;  80008 - VS IT("SHAD")   ; PROJ 1 12/SHAD (s et)"RTN"," VSITHLP",8 1,0) ;; 80 009 - VSIT ("CLV") ;  CAMP LEJEU NE (set)"R TN","VSITH LP",82,0)  ;; 81101 -  VSIT("COM ") ; COMME NTS (free  text)"RTN" ,"VSITHLP" ,83,0) ;;  81202 - VS IT("PKG")  ; PACKAGE  (pointer t o PACKAGE  file #9.4) "RTN","VSI THLP",84,0 ) ;; 81203  - VSIT("S OR") ; DAT A SOURCE ( pointer to  PCE DATA  SOURCE"RTN ","VSITHLP ",85,0) ;;                          file #8 39.7)"RTN" ,"VSITHLP" ,86,0) ;   djs  PX*1. 0*207  RSD  SPEC #2.6 .2.1.1  Ad ded text f or Camp Le jeune abov e"VER")8.0 ^22.2"^DD" ,9000010,9 000010,800 09,0)CAMP  LEJEUNE^S^ 1:YES;0:NO ;^800;9^Q" ^DD",90000 10,9000010 ,80009,.1) CAMP LEJEU NE ELIGIBI LITY INDIC ATOR"^DD", 9000010,90 00010,8000 9,3)If thi s visit is  treating  a Camp Lej eune Expos ure proble m, enter " YES" here. "^DD",9000 010,900001 0,80009,21 ,0)^.001^2 ^2^3171121 ^^^"^DD",9 000010,900 0010,80009 ,21,1,0)Th is field i s used to  indicate t hat this v isit repre sents trea tment of a  "^DD",900 0010,90000 10,80009,2 1,2,0)VA p atient for  a problem  that is r elated to  Camp Lejeu ne Exposur e."^DD",90 00010,9000 010,80009, 23,0)^.001 ^1^1^31711 21^^^"^DD" ,9000010,9 000010,800 09,23,1,0) This data  may be pas sed to the  Visit fro m MCCR eve nt data ca pture."^DD ",9000010, 9000010,80 009,"DT")3 150311"^DD ",9000010, 9000010,80 019,0)CAMP  LEJEUNE E DIT FLAG^S ^0:EDITABL E;1:NOT ED ITABLE;^80 0;19^Q"^DD ",9000010, 9000010,80 019,3)Ente r 1 to pre vent user  editing of  the Camp  Lejeune cl assificati on."^DD",9 000010,900 0010,80019 ,21,0)^^2^ 2^3150313^ "^DD",9000 010,900001 0,80019,21 ,1,0)This  field is u sed to det ermine if  the Camp L ejeune cla ssificatio n for"^DD" ,9000010,9 000010,800 19,21,2,0) the Visit  can be edi ted by the  user."^DD ",9000010, 9000010,80 019,23,0)^ ^3^3^31503 13^"^DD",9 000010,900 0010,80019 ,23,1,0)Th e Camp Lej eune class ification  is not edi table if e ither any  of the"^DD ",9000010, 9000010,80 019,23,2,0 )diagnosis  Camp Leje une classi fications  are "Yes"  or all of  the diagno sis"^DD",9 000010,900 0010,80019 ,23,3,0)Ca mp Lejeune  classific ations are  "No"."^DD ",9000010, 9000010,80 019,"DT")3 150311"^DD ",9000010. 07,9000010 .07,80009, 0)CAMP LEJ EUNE^S^1:Y ES;0:NO;^8 00;9^Q"^DD ",9000010. 07,9000010 .07,80009, .1)CAMP LE JEUNE ELIG IBILITY IN DICATOR"^D D",9000010 .07,900001 0.07,80009 ,3)If the  problem tr eated is r elated to  Camp Lejeu ne Exposur e, enter " YES" here. "^DD",9000 010.07,900 0010.07,80 009,21,0)^ ^2^2^31505 29^"^DD",9 000010.07, 9000010.07 ,80009,21, 1,0)This f ield is us ed in the  VA to indi cate that  this probl em treated  at "^DD", 9000010.07 ,9000010.0 7,80009,21 ,2,0)this  visit was  related to  Camp Leje une Exposu re."^DD",9 000010.07, 9000010.07 ,80009,23, 0)^.001^5^ 5^3150529^ ^^"^DD",90 00010.07,9 000010.07, 80009,23,1 ,0)This fi eld is use d by the V A.  The da ta is only  passed to  PCE from  the "^DD", 9000010.07 ,9000010.0 7,80009,23 ,2,0)autom ated data  capture of  encounter  form data .  If a pr oblem from  the "^DD" ,9000010.0 7,9000010. 07,80009,2 3,3,0)Acti ve Problem  List is i dentified  as the pro blem treat ed at the  visit, "^D D",9000010 .07,900001 0.07,80009 ,23,4,0)an d the prob lem has be en associa ted with C amp Lejeun e Exposure  in the "^ DD",900001 0.07,90000 10.07,8000 9,23,5,0)P roblem Lis t, then th e POV's Ca mp Lejeune  Exposure  will be se t to "1"." ^DD",90000 10.07,9000 010.07,800 09,"DT")31 50312**INS TALL NAME* *SD*5.3*63 1"BLD",923 4,0)SD*5.3 *631^SCHED ULING^0^31 80123^y"BL D",9234,1, 0)^^1^1^31 71117^"BLD ",9234,1,1 ,0)Please  refer to t he patch d escription  for detai ls."BLD",9 234,4,0)^9 .64PA^409. 92^3"BLD", 9234,4,409 .41,0)409. 41"BLD",92 34,4,409.4 1,222)y^y^ f^^n^^y^o^ n"BLD",923 4,4,409.41 ,224)I Y=9 "BLD",9234 ,4,409.76, 0)409.76"B LD",9234,4 ,409.76,22 2)y^y^f^^n ^^y^o^n"BL D",9234,4, 409.76,224 )I (Y=304) !(Y=305)"B LD",9234,4 ,409.92,0) 409.92"BLD ",9234,4,4 09.92,222) y^y^f^^n^^ y^o^n"BLD" ,9234,4,40 9.92,224)I  (Y=83)!(Y =84)"BLD", 9234,4,"B" ,409.41,40 9.41)"BLD" ,9234,4,"B ",409.76,4 09.76)"BLD ",9234,4," B",409.92, 409.92)"BL D",9234,6. 3)57"BLD", 9234,"ABPK G")n"BLD", 9234,"INI" )"BLD",923 4,"INID")^ y^"BLD",92 34,"INIT") SD53631P"B LD",9234," KRN",0)^9. 67PA^779.2 ^20"BLD",9 234,"KRN", .4,0).4"BL D",9234,"K RN",.4,"NM ",0)^9.68A ^^"BLD",92 34,"KRN",. 401,0).401 "BLD",9234 ,"KRN",.40 2,0).402"B LD",9234," KRN",.403, 0).403"BLD ",9234,"KR N",.5,0).5 "BLD",9234 ,"KRN",.84 ,0).84"BLD ",9234,"KR N",3.6,0)3 .6"BLD",92 34,"KRN",3 .8,0)3.8"B LD",9234," KRN",9.2,0 )9.2"BLD", 9234,"KRN" ,9.8,0)9.8 "BLD",9234 ,"KRN",9.8 ,"NM",0)^9 .68A^26^17 "BLD",9234 ,"KRN",9.8 ,"NM",1,0) SCDXMSG1^^ 0^B7479621 5"BLD",923 4,"KRN",9. 8,"NM",2,0 )SCDXUTL0^ ^0^B387003 88"BLD",92 34,"KRN",9 .8,"NM",5, 0)SCMSVUT3 ^^0^B22241 134"BLD",9 234,"KRN", 9.8,"NM",6 ,0)SCMSVZE L^^0^B9007 520"BLD",9 234,"KRN", 9.8,"NM",1 0,0)SCRPW2 3^^0^B5669 8845"BLD", 9234,"KRN" ,9.8,"NM", 11,0)SCRPW 24^^0^B803 15888"BLD" ,9234,"KRN ",9.8,"NM" ,12,0)SCRP W25^^0^B75 266483"BLD ",9234,"KR N",9.8,"NM ",15,0)SDA MEP2^^0^B3 1765792"BL D",9234,"K RN",9.8,"N M",16,0)SD CO0^^0^B33 156104"BLD ",9234,"KR N",9.8,"NM ",19,0)SDP CE^^0^B421 50048"BLD" ,9234,"KRN ",9.8,"NM" ,20,0)SDPP AT1^^0^B22 865926"BLD ",9234,"KR N",9.8,"NM ",21,0)SDP PAT2^^0^B3 3407191"BL D",9234,"K RN",9.8,"N M",22,0)SC CVPCE^^0^B 45010356"B LD",9234," KRN",9.8," NM",23,0)S DAPICO1^^0 ^B11063728 "BLD",9234 ,"KRN",9.8 ,"NM",24,0 )SDCO2^^0^ B4032333"B LD",9234," KRN",9.8," NM",25,0)S DCO21^^0^B 6653603"BL D",9234,"K RN",9.8,"N M",26,0)SD CO22^^0^B1 3353144"BL D",9234,"K RN",9.8,"N M","B","SC CVPCE",22) "BLD",9234 ,"KRN",9.8 ,"NM","B", "SCDXMSG1" ,1)"BLD",9 234,"KRN", 9.8,"NM"," B","SCDXUT L0",2)"BLD ",9234,"KR N",9.8,"NM ","B","SCM SVUT3",5)" BLD",9234, "KRN",9.8, "NM","B"," SCMSVZEL", 6)"BLD",92 34,"KRN",9 .8,"NM","B ","SCRPW23 ",10)"BLD" ,9234,"KRN ",9.8,"NM" ,"B","SCRP W24",11)"B LD",9234," KRN",9.8," NM","B","S CRPW25",12 )"BLD",923 4,"KRN",9. 8,"NM","B" ,"SDAMEP2" ,15)"BLD", 9234,"KRN" ,9.8,"NM", "B","SDAPI CO1",23)"B LD",9234," KRN",9.8," NM","B","S DCO0",16)" BLD",9234, "KRN",9.8, "NM","B"," SDCO2",24) "BLD",9234 ,"KRN",9.8 ,"NM","B", "SDCO21",2 5)"BLD",92 34,"KRN",9 .8,"NM","B ","SDCO22" ,26)"BLD", 9234,"KRN" ,9.8,"NM", "B","SDPCE ",19)"BLD" ,9234,"KRN ",9.8,"NM" ,"B","SDPP AT1",20)"B LD",9234," KRN",9.8," NM","B","S DPPAT2",21 )"BLD",923 4,"KRN",19 ,0)19"BLD" ,9234,"KRN ",19,"NM", 0)^9.68A^^ "BLD",9234 ,"KRN",19. 1,0)19.1"B LD",9234," KRN",19.1, "NM",0)^9. 68A^^"BLD" ,9234,"KRN ",101,0)10 1"BLD",923 4,"KRN",10 1,"NM",0)^ 9.68A^^"BL D",9234,"K RN",409.61 ,0)409.61" BLD",9234, "KRN",771, 0)771"BLD" ,9234,"KRN ",779.2,0) 779.2"BLD" ,9234,"KRN ",870,0)87 0"BLD",923 4,"KRN",89 89.51,0)89 89.51"BLD" ,9234,"KRN ",8989.52, 0)8989.52" BLD",9234, "KRN",8994 ,0)8994"BL D",9234,"K RN",8994," NM",0)^9.6 8A^^"BLD", 9234,"KRN" ,"B",.4,.4 )"BLD",923 4,"KRN","B ",.401,.40 1)"BLD",92 34,"KRN"," B",.402,.4 02)"BLD",9 234,"KRN", "B",.403,. 403)"BLD", 9234,"KRN" ,"B",.5,.5 )"BLD",923 4,"KRN","B ",.84,.84) "BLD",9234 ,"KRN","B" ,3.6,3.6)" BLD",9234, "KRN","B", 3.8,3.8)"B LD",9234," KRN","B",9 .2,9.2)"BL D",9234,"K RN","B",9. 8,9.8)"BLD ",9234,"KR N","B",19, 19)"BLD",9 234,"KRN", "B",19.1,1 9.1)"BLD", 9234,"KRN" ,"B",101,1 01)"BLD",9 234,"KRN", "B",409.61 ,409.61)"B LD",9234," KRN","B",7 71,771)"BL D",9234,"K RN","B",77 9.2,779.2) "BLD",9234 ,"KRN","B" ,870,870)" BLD",9234, "KRN","B", 8989.51,89 89.51)"BLD ",9234,"KR N","B",898 9.52,8989. 52)"BLD",9 234,"KRN", "B",8994,8 994)"BLD", 9234,"QDEF ")^^^^NO^^ ^^NO^^NO"B LD",9234," QUES",0)^9 .62^^"BLD" ,9234,"REQ B",0)^9.61 1^9^8"BLD" ,9234,"REQ B",1,0)SD* 5.3*211^1" BLD",9234, "REQB",2,0 )SD*5.3*23 2^1"BLD",9 234,"REQB" ,4,0)SD*5. 3*543^1"BL D",9234,"R EQB",5,0)S D*5.3*544^ 1"BLD",923 4,"REQB",6 ,0)SD*5.3* 552^1"BLD" ,9234,"REQ B",7,0)SD* 5.3*585^1" BLD",9234, "REQB",8,0 )SD*5.3*58 6^1"BLD",9 234,"REQB" ,9,0)SD*5. 3*593^1"BL D",9234,"R EQB","B"," SD*5.3*211 ",1)"BLD", 9234,"REQB ","B","SD* 5.3*232",2 )"BLD",923 4,"REQB"," B","SD*5.3 *543",4)"B LD",9234," REQB","B", "SD*5.3*54 4",5)"BLD" ,9234,"REQ B","B","SD *5.3*552", 6)"BLD",92 34,"REQB", "B","SD*5. 3*585",7)" BLD",9234, "REQB","B" ,"SD*5.3*5 86",8)"BLD ",9234,"RE QB","B","S D*5.3*593" ,9)"DATA", 409.41,9,0 )CAMP LEJE UNE^Was tr eatment re lated to C amp Lejeun e Exposure ^Y^^1^Camp  Lejeune E xposure^CL V"DATA",40 9.41,9,1)I  $$CLV^SDC O22(DFN,$G (SDOE))"DA TA",409.41 ,9,"E",0)^ 409.4175DA ^1^1"DATA" ,409.41,9, "E",1,0)31 20806^1"DA TA",409.76 ,304,0)739 ^N"DATA",4 09.76,304, 1)Camp Lej eune is mi ssing or i nvalid"DAT A",409.76, 304,2,0)^4 09.7621^2^ 2^3160211^ ^^^"DATA", 409.76,304 ,2,1,0)Rev iew Camp L ejeune dat a through  the Load/E dit Patien t Data pro tocol, "DA TA",409.76 ,304,2,2,0 )Screen 6,  Group 3,  Option 5." DATA",409. 76,304,"CH K")S RES=$ $CL^SCMSVU T3(DATA,DF N)"DATA",4 09.76,304, "COR")S RT N=$$LEDT^S CENIA1()"D ATA",409.7 6,305,0)73 90^V"DATA" ,409.76,30 5,1)Camp L ejeune is  missing or  invalid"D ATA",409.7 6,305,2,0) ^^2^2^3150 422^"DATA" ,409.76,30 5,2,1,0)Re view Camp  Lejeune da ta through  the Load/ Edit Patie nt Data pr otocol, "D ATA",409.7 6,305,2,2, 0)Screen 6 , Group 3,  Option 5. "DATA",409 .76,305,"C HK")S RES= $$CL^SCMSV UT3(DATA,D FN)"DATA", 409.76,305 ,"COR")S R TN=$$LEDT^ SCENIA1()" DATA",409. 92,83,0)12 14^OE^OUTP ATIENT ENC OUNTER^CL^ CAMP LEJEU NE CLASS.^ S^^^L^100^ ^^^^1^0"DA TA",409.92 ,83,1)OECL "DATA",409 .92,83,7)D  CLQ^SCRPW 24(.DIR,"C ")"DATA",4 09.92,83,1 1)D OECL^S CRPW24(.SD X,"C")"DAT A",409.92, 84,0)0812^ PE^PATIENT  ELIGIBILI TY^CL^CAMP  LEJEUNE^S ^^^LR^100^ ^^^^2^0"DA TA",409.92 ,84,1)PECL "DATA",409 .92,84,7)D  CLQ^SCRPW 25(.DIR)"D ATA",409.9 2,84,11)D  PECL^SCRPW 25(.SDX)"F IA",409.41 )OUTPATIEN T CLASSIFI CATION TYP E"FIA",409 .41,0)^SD( 409.41,"FI A",409.41, 0,0)409.41 "FIA",409. 41,0,1)y^y ^f^^n^^y^o ^n"FIA",40 9.41,0,10) "FIA",409. 41,0,11)I  Y=9"FIA",4 09.41,0,"R LRO")"FIA" ,409.41,0, "VR")5.3^S D"FIA",409 .41,409.41 )0"FIA",40 9.41,409.4 15)0"FIA", 409.41,409 .4175)0"FI A",409.76) TRANSMITTE D OUTPATIE NT ENCOUNT ER ERROR C ODE"FIA",4 09.76,0)^S D(409.76," FIA",409.7 6,0,0)409. 76I"FIA",4 09.76,0,1) y^y^f^^n^^ y^o^n"FIA" ,409.76,0, 10)"FIA",4 09.76,0,11 )I (Y=304) !(Y=305)"F IA",409.76 ,0,"RLRO") "FIA",409. 76,0,"VR") 5.3^SD"FIA ",409.76,4 09.76)0"FI A",409.76, 409.7621)0 "FIA",409. 92)ACRP RE PORT TEMPL ATE PARAME TER"FIA",4 09.92,0)^S D(409.92," FIA",409.9 2,0,0)409. 92I"FIA",4 09.92,0,1) y^y^f^^n^^ y^o^n"FIA" ,409.92,0, 10)"FIA",4 09.92,0,11 )I (Y=83)! (Y=84)"FIA ",409.92,0 ,"RLRO")"F IA",409.92 ,0,"VR")5. 3^SD"FIA", 409.92,409 .92)0"INIT ")SD53631P "MBREQ")0" PKG",16,-1 )1^1"PKG", 16,0)SCHED ULING^SD^A PPOINTMENT S,PROFILES ,LETTERS,A MIS REPORT S"PKG",16, 20,0)^9.40 2P^^"PKG", 16,22,0)^9 .49I^1^1"P KG",16,22, 1,0)5.3^29 30813^2930 824"PKG",1 6,22,1,"PA H",1,0)631 ^3180123^1 0000000007 "PKG",16,2 2,1,"PAH", 1,1,0)^^1^ 1^3180123" PKG",16,22 ,1,"PAH",1 ,1,1,0)Ple ase refer  to the pat ch descrip tion for d etails."QU ES","XPF1" ,0)Y"QUES" ,"XPF1","? ?")^D REP^ XPDH"QUES" ,"XPF1","A ")Shall I  write over  your |FLA G| File"QU ES","XPF1" ,"B")YES"Q UES","XPF1 ","M")D XP F1^XPDIQ"Q UES","XPF2 ",0)Y"QUES ","XPF2"," ??")^D DTA ^XPDH"QUES ","XPF2"," A")Want my  data |FLA G| yours"Q UES","XPF2 ","B")YES" QUES","XPF 2","M")D X PF2^XPDIQ" QUES","XPI 1",0)YO"QU ES","XPI1" ,"??")^D I NHIBIT^XPD H"QUES","X PI1","A")W ant KIDS t o INHIBIT  LOGONs dur ing the in stall"QUES ","XPI1"," B")NO"QUES ","XPI1"," M")D XPI1^ XPDIQ"QUES ","XPM1",0 )PO^VA(200 ,:EM"QUES" ,"XPM1","? ?")^D MG^X PDH"QUES", "XPM1","A" )Enter the  Coordinat or for Mai l Group '| FLAG|'"QUE S","XPM1", "B")"QUES" ,"XPM1","M ")D XPM1^X PDIQ"QUES" ,"XPO1",0) Y"QUES","X PO1","??") ^D MENU^XP DH"QUES"," XPO1","A") Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install"Q UES","XPO1 ","B")NO"Q UES","XPO1 ","M")D XP O1^XPDIQ"Q UES","XPZ1 ",0)Y"QUES ","XPZ1"," ??")^D OPT ^XPDH"QUES ","XPZ1"," A")Want to  DISABLE S cheduled O ptions, Me nu Options , and Prot ocols"QUES ","XPZ1"," B")NO"QUES ","XPZ1"," M")D XPZ1^ XPDIQ"QUES ","XPZ2",0 )Y"QUES"," XPZ2","??" )^D RTN^XP DH"QUES"," XPZ2","A") Want to MO VE routine s to other  CPUs"QUES ","XPZ2"," B")NO"QUES ","XPZ2"," M")D XPZ2^ XPDIQ"RTN" )18"RTN"," SCCVPCE")0 ^22^B45010 356"RTN"," SCCVPCE",1 ,0)SCCVPCE  ;ALB/TMP  - Send dat a to PCE;  [ 01/28/98   10:19 AM  ]"RTN","S CCVPCE",2, 0) ;;5.3;S cheduling; **211,631* *;Aug 13,  1993;Build  57"RTN"," SCCVPCE",3 ,0) ;"RTN" ,"SCCVPCE" ,4,0)DATA2 PCE(SDOE,S CCONS,SCCV EVT,SCOEP, SCDTM,SCDA ,SCEST) ;  -- send da ta to pce" RTN","SCCV PCE",5,0)  ;Input:"RT N","SCCVPC E",6,0) ;    SCOE      Internal  entry # of  encounter "RTN","SCC VPCE",7,0)  ;   SCCON S   Array  containing  constant  data for t he convers ion ..."RT N","SCCVPC E",8,0) ;                 needed  for recon vert to wo rk properl y"RTN","SC CVPCE",9,0 ) ;             ("PKG ")  = Sche duling pac kage point er"RTN","S CCVPCE",10 ,0) ;             ("S RCE") = so urce name  for the co nversion"R TN","SCCVP CE",11,0)  ;   SCCVEV T   1 for  estimate,  2 for conv ert"RTN"," SCCVPCE",1 2,0) ;   S COEP    Pa rent encou nter [opti onal]"RTN" ,"SCCVPCE" ,13,0) ;    SCDTM     Date/time  of add/edi t entry if  no encoun ter [optio nal]"RTN", "SCCVPCE", 14,0) ;    SCDA     ' CS' entry  ien if add /edit, no  encounter  [optional] "RTN","SCC VPCE",15,0 ) ;Output: "RTN","SCC VPCE",16,0 ) ;   SCES T  Variabl e of '^' p ieces that  contain #  of entrie s to be ad ded:"RTN", "SCCVPCE", 17,0) ;             #  providers ^# diagnos es^# proce dures "RTN ","SCCVPCE ",18,0) ;" RTN","SCCV PCE",19,0)  N PXKNOEV T,SDOE0,X, SDVST,SDPR V,SDIAG,SD CLS,SDPROC ,SCPCE,SDO EC,SCE,SCE RRM"RTN"," SCCVPCE",2 0,0) ;"RTN ","SCCVPCE ",21,0) K  ^TMP("PXK- SD",$J),^T MP("PXK",$ J)"RTN","S CCVPCE",22 ,0) S SCES T=0"RTN"," SCCVPCE",2 3,0) ; --  gather nee ded data"R TN","SCCVP CE",24,0)  S SDOE0=$G (^SCE(SDOE ,0))"RTN", "SCCVPCE", 25,0) ;"RT N","SCCVPC E",26,0) I  SCCVEVT G  DATAQ:SDO E0="""RTN" ,"SCCVPCE" ,27,0) ;"R TN","SCCVP CE",28,0)  S SDVST=$S ('$G(SCOEP ):+$P(SDOE 0,U,5),1:+ $P($G(^SCE (SCOEP,0)) ,U,5))"RTN ","SCCVPCE ",29,0) ;" RTN","SCCV PCE",30,0)  I SCCVEVT  G DATAQ:' SDVST"RTN" ,"SCCVPCE" ,31,0) ;"R TN","SCCVP CE",32,0)  ; -- if ch ild visit  and has v- file data  quit"RTN", "SCCVPCE", 33,0) I $S ('$G(SCOEP ):0,1:$O(^ AUPNVCPT(" AD",SDVST, 0))!($O(^A UPNVPRV("A D",SDVST,0 )))!($O(^A UPNVPOV("A D",SDVST,0 )))) G DAT AQ"RTN","S CCVPCE",34 ,0) ;"RTN" ,"SCCVPCE" ,35,0) ; - - Get data  from enco unter for  providers,  diagnoses , classifi cations"RT N","SCCVPC E",36,0) D  SET(SDOE, "SDPRV",40 9.44)"RTN" ,"SCCVPCE" ,37,0) D S ET(SDOE,"S DIAG",409. 43)"RTN"," SCCVPCE",3 8,0) D SET (SDOE,"SDC LS",409.42 )"RTN","SC CVPCE",39, 0) ; -- Ge t data for  procedure s"RTN","SC CVPCE",40, 0) I '$G(S COEP) D  ;  look for  parents on ly so data  not dupli cated"RTN" ,"SCCVPCE" ,41,0) . D  PROC(SDOE ,+$G(SCDTM ),+$G(SCDA ),SCCVEVT, "SDPROC")" RTN","SCCV PCE",42,0)  ;"RTN","S CCVPCE",43 ,0) ; -- B uild PCE d ata array" RTN","SCCV PCE",44,0)  D BUILD(" SDPRV","SD IAG","SDCL S","SDPROC ","SCPCE", "^TMP(""PX K-SD"","_$ J_")",+$P( SDOE0,U,2) ,SDVST)"RT N","SCCVPC E",45,0) ; "RTN","SCC VPCE",46,0 ) ; For Es timate, co unt # of c pt's, dx's , provider s to be ad ded"RTN"," SCCVPCE",4 7,0) I 'SC CVEVT D  G  DATAQ ;Es timate exi ts here"RT N","SCCVPC E",48,0) .  S SCEST=+ $O(^TMP("P XK-SD",$J, "PRV",""), -1)_U_+$O( SCPCE("DX/ PL",""),-1 )_U_+$O(SC PCE("PROCE DURE",""), -1)"RTN"," SCCVPCE",4 9,0) ;"RTN ","SCCVPCE ",50,0) ;  -- Call PC E APIs to  file addit ional data "RTN","SCC VPCE",51,0 ) S PXKNOE VT=1 ;Need ed to keep  sched eve nts from b eing fired  off by PC E"RTN","SC CVPCE",52, 0) ;"RTN", "SCCVPCE", 53,0) I $D (SCPCE),$$ DATA2PCE^P XAPI("SCPC E",$G(SCCO NS("PKG")) ,$G(SCCONS ("SRCE")), SDVST)<0 D "RTN","SCC VPCE",54,0 ) . N Z,Z0 ,Z1,SCTEXT ,SCX"RTN", "SCCVPCE", 55,0) . S  (Z,Z1)=0"R TN","SCCVP CE",56,0)  . F  S Z=$ O(SCPCE("D IERR",Z))  Q:'Z  S Z0 =0 F  S Z0 =$O(SCPCE( "DIERR",Z, "TEXT",Z0) ) Q:'Z0  S  SCTEXT=$T R(SCPCE("D IERR",Z,"T EXT",Z0),"  ") I SCTE XT'="" D"R TN","SCCVP CE",57,0)  .. S:Z0=1& (Z>1) Z1=Z 1+1,SCERRM (Z1)="  -- ---""RTN", "SCCVPCE", 58,0) .. I  SCTEXT["S CPCE.." S  SCX=$P(SCT EXT,"=",2)  D  Q"RTN" ,"SCCVPCE" ,59,0) ...  I SCTEXT[ "DX/PL" S  Z1=Z1+1,SC ERRM(Z1)="   DIAGNOSI S "_+SCX_"  ("_$S($D( ^ICD9(+SCX ,0)):$P(^( 0),U),1:"U NDEFINED") _") WAS NO T CONVERTE D" D SETER R^SCCVZZ(" POV",SCOE, +SCX,$G(SC LOG))"RTN" ,"SCCVPCE" ,60,0) ...  I SCTEXT[ "PROCEDURE " S Z1=Z1+ 1,SCERRM(Z 1)="  PROC EDURE "_+S CX_" ("_$S ($D(^ICPT( +SCX,0)):$ P(^(0),U), 1:"UNDEFIN ED")_") WA S NOT CONV ERTED" D S ETERR^SCCV ZZ("CPT",S COE,+SCX,$ G(SCLOG))" RTN","SCCV PCE",61,0)  .. S Z1=Z 1+1,SCERRM (Z1)=SCPCE ("DIERR",Z ,"TEXT",Z0 )"RTN","SC CVPCE",62, 0) . S SCE ("DFN")=$P (SDOE0,U,2 ),SCE("ENC ")=SDOE,SC E("VSIT")= SDVST,SCE( "DATE")=+S DOE0"RTN", "SCCVPCE", 63,0) . I  $O(SCERRM( "")) D"RTN ","SCCVPCE ",64,0) ..  D LOGERR^ SCCVLOG1($ G(SCLOG),. SCERRM,.SC E,.SCCVERR H)"RTN","S CCVPCE",65 ,0) .. I ' $G(SCLOG)  D"RTN","SC CVPCE",66, 0) ... N Z ,Z0 S Z=0, Z0=$O(SCER RMSG(""),- 1) F  S Z= $O(SCERRM( Z)) Q:'Z   S Z0=Z0+1, SCERRMSG(Z 0)=SCERRM( Z,0)"RTN", "SCCVPCE", 67,0) ;"RT N","SCCVPC E",68,0) I  $D(^TMP(" PXK-SD",$J )) D  ;Con vert provi ders"RTN", "SCCVPCE", 69,0) . N  Z,Z0,Z1,SC TEXT,SCX"R TN","SCCVP CE",70,0)  . M ^TMP(" PXK",$J)=^ TMP("PXK-S D",$J)"RTN ","SCCVPCE ",71,0) .  K ^TMP("PX K-SD",$J)" RTN","SCCV PCE",72,0)  . D EN1^P XKMAIN"RTN ","SCCVPCE ",73,0) .  S Z="PXKER ROR(""PRV" ")",Z1=0"R TN","SCCVP CE",74,0)  . F  S Z=$ G(@Z) Q:Z' ["PXKERROR (""PRV"""   S SCTEXT= $G(@Z) D"R TN","SCCVP CE",75,0)  .. S SCX=+ $G(^TMP("P XK",$J,"PR V",+$QS(Z, 2),0,"AFTE R"))"RTN", "SCCVPCE", 76,0) .. S  Z1=Z1+1 S :Z1>1 SCER RM(Z1)="   -----",Z1= Z1+1"RTN", "SCCVPCE", 77,0) .. S  SCERRM(Z1 )="  PROVI DER ERROR  "_SCX_" (" _$S($D(^VA (200,SCX,0 )):$P(^(0) ,U),1:"UND EFINED")_" ) WAS NOT  CONVERTED" "RTN","SCC VPCE",78,0 ) .. S Z1= Z1+1,SCERR M(Z1)="     "_SCTEXT" RTN","SCCV PCE",79,0)  .. D SETE RR^SCCVZZ( "PRV",SCOE ,SCX,$G(SC LOG))"RTN" ,"SCCVPCE" ,80,0) . K  ^TMP("PXK ",$J),PXKE RROR"RTN", "SCCVPCE", 81,0) ;"RT N","SCCVPC E",82,0)DA TAQ Q"RTN" ,"SCCVPCE" ,83,0) ;"R TN","SCCVP CE",84,0)B UILD(SDPRO V,SDDX,SDC LASS,SDCPT ,SDATA,SPD ATA,DFN,SD VST) ; --  bld pce da ta arrays" RTN","SCCV PCE",85,0)  N X,SDI,S DIEN,SDCNT ,SDSEQ,SCS RCE"RTN"," SCCVPCE",8 6,0) S SCS RCE=$$SOUR CE^PXAPI($ G(SCCONS(" SRCE")))"R TN","SCCVP CE",87,0)  S SDI=0 F   S SDI=$O( @SDCLASS@( SDI)) Q:'S DI  D"RTN" ,"SCCVPCE" ,88,0) . S  X=@SDCLAS S@(SDI)"RT N","SCCVPC E",89,0) .  S @SDATA@ ("ENCOUNTE R",1,$P("A O^IR^SC^EC ^CLV",U,+X ))=$P(X,U, 3)              ; SD* 5.3*631"RT N","SCCVPC E",90,0) ; "RTN","SCC VPCE",91,0 ) ; -- set  dx info"R TN","SCCVP CE",92,0)  I $O(@SDDX @(0)) D"RT N","SCCVPC E",93,0) .  S (SDCNT, SDIEN)=0"R TN","SCCVP CE",94,0)  . F  S SDI EN=$O(@SDD X@(SDIEN))  Q:'SDIEN   D"RTN","S CCVPCE",95 ,0) . . S  X=@SDDX@(S DIEN)"RTN" ,"SCCVPCE" ,96,0) . .  S SDCNT=S DCNT+1"RTN ","SCCVPCE ",97,0) .  . S @SDATA @("DX/PL", SDCNT,"DIA GNOSIS")=+ X"RTN","SC CVPCE",98, 0) ;"RTN", "SCCVPCE", 99,0) ; --  set cpt i nfo"RTN"," SCCVPCE",1 00,0) I $O (@SDCPT@(0 )) D"RTN", "SCCVPCE", 101,0) . ;  -- count  times perf ormed"RTN" ,"SCCVPCE" ,102,0) .  N SDX"RTN" ,"SCCVPCE" ,103,0) .  S (SDCNT,S DSEQ)=0"RT N","SCCVPC E",104,0)  . F  S SDS EQ=$O(@SDC PT@(SDSEQ) ) Q:'SDSEQ   D"RTN"," SCCVPCE",1 05,0) . .  S SDIEN=@S DCPT@(SDSE Q)"RTN","S CCVPCE",10 6,0) . . S  SDX(+SDIE N)=$G(SDX( +SDIEN))+1 "RTN","SCC VPCE",107, 0) . ;"RTN ","SCCVPCE ",108,0) .  ; -- buil d nodes"RT N","SCCVPC E",109,0)  . S (SDCNT ,SDIEN)=0" RTN","SCCV PCE",110,0 ) . F  S S DIEN=$O(SD X(SDIEN))  Q:'SDIEN   D"RTN","SC CVPCE",111 ,0) . . S  X=SDX(SDIE N)"RTN","S CCVPCE",11 2,0) . . S  SDCNT=SDC NT+1"RTN", "SCCVPCE", 113,0) . .  S @SDATA@ ("PROCEDUR E",SDCNT," PROCEDURE" )=SDIEN"RT N","SCCVPC E",114,0)  . . S @SDA TA@("PROCE DURE",SDCN T,"QTY")=+ X"RTN","SC CVPCE",115 ,0) ;"RTN" ,"SCCVPCE" ,116,0) ;  -- build p rov pce da ta array t o be stuff ed"RTN","S CCVPCE",11 7,0) ; Mus t be separ ate to cal l EN1^PXKM AIN to add  so no che ck for pro v class"RT N","SCCVPC E",118,0)  ;"RTN","SC CVPCE",119 ,0) I $O(@ SDPROV@(0) ) D"RTN"," SCCVPCE",1 20,0) . K  @SPDATA"RT N","SCCVPC E",121,0)  . S (SDCNT ,SDIEN)=0" RTN","SCCV PCE",122,0 ) . S @SPD ATA@("VST" ,1,0,"AFTE R")=$G(^AU PNVSIT(SDV ST,0))"RTN ","SCCVPCE ",123,0) .  S @SPDATA @("VST",1, 0,"BEFORE" )=@SPDATA@ ("VST",1,0 ,"AFTER")" RTN","SCCV PCE",124,0 ) . F  S S DIEN=$O(@S DPROV@(SDI EN)) Q:'SD IEN  D"RTN ","SCCVPCE ",125,0) .  . S X=@SD PROV@(SDIE N),SDCNT=S DCNT+1"RTN ","SCCVPCE ",126,0) .  . S @SPDA TA@("SOR") =SCSRCE"RT N","SCCVPC E",127,0)  . . S @SPD ATA@("PRV" ,SDCNT,0," BEFORE")=" ""RTN","SC CVPCE",128 ,0) . . S  @SPDATA@(" PRV",SDCNT ,0,"AFTER" )=+X_U_DFN _U_SDVST_U _$S(SDCNT= 1:"P",1:"S ")_U"RTN", "SCCVPCE", 129,0) . .  S @SPDATA @("PRV",SD CNT,812,"B EFORE")="" "RTN","SCC VPCE",130, 0) . . S @ SPDATA@("P RV",SDCNT, 812,"AFTER ")=U_$G(SC CONS("PKG" ))_U_$$SOU RCE^PXAPI( $G(SCCONS( "SRCE")))" RTN","SCCV PCE",131,0 ) . . S @S PDATA@("PR V",SDCNT," IEN")="""R TN","SCCVP CE",132,0)  . . S @SP DATA@("VST ",SDCNT,"I EN")=SDVST "RTN","SCC VPCE",133, 0) ;"RTN", "SCCVPCE", 134,0) Q"R TN","SCCVP CE",135,0)  ;"RTN","S CCVPCE",13 6,0)BUILDQ  Q"RTN","S CCVPCE",13 7,0) ;"RTN ","SCCVPCE ",138,0)SE T(SDOE,ARR AY,FILE) ; Set-up Arr ay for Out patient En counter"RT N","SCCVPC E",139,0)  ; Input  - - SDOE       Outpatie nt Encount er IEN"RTN ","SCCVPCE ",140,0) ;  Output --  ARRAY      Provider  or dx Arra y Subscrip ted by ien "RTN","SCC VPCE",141, 0) ;"RTN", "SCCVPCE", 142,0) N S DIEN,SDDUP ,SDCNT"RTN ","SCCVPCE ",143,0) S  SDIEN=0,S DCNT=0"RTN ","SCCVPCE ",144,0) F   S SDIEN= $O(^SDD(FI LE,"OE",SD OE,SDIEN))  Q:'SDIEN   D"RTN","S CCVPCE",14 5,0) . S X =$G(^SDD(F ILE,SDIEN, 0)) Q:X="" !$S(FILE'[ ".42":$D(S DDUP(+X)), 1:0)"RTN", "SCCVPCE", 146,0) . S  SDCNT=SDC NT+1,@ARRA Y@(SDCNT)= X,SDDUP(+X )="""RTN", "SCCVPCE", 147,0) Q"R TN","SCCVP CE",148,0)  ;"RTN","S CCVPCE",14 9,0)PROC(S DOE,SCDTM, SCDA,SCCVE VT,SCDXARR Y) ;"RTN", "SCCVPCE", 150,0) ; S DOE = enco unter ien" RTN","SCCV PCE",151,0 ) ; SCDTM  = if estim ating and  no enctr,  dt/tm of t he new enc ounter [op t]"RTN","S CCVPCE",15 2,0) ; SCD A  = if es timating a nd no enct r, 'CS' no de entry [ opt]"RTN", "SCCVPCE", 153,0) ; S CCVEVT = c onversion  event"RTN" ,"SCCVPCE" ,154,0) ;  SCDXARRY =  name of a rray to re turn"RTN", "SCCVPCE", 155,0) N C NT,SDOEC"R TN","SCCVP CE",156,0)  S CNT=0,S DOE=+$G(SD OE),SDOEC= """RTN","S CCVPCE",15 7,0) I 'SD OE,'SCDTM, 'SCDA G PR OCQ"RTN"," SCCVPCE",1 58,0) ;"RT N","SCCVPC E",159,0)  ; - Use pa rent encou nter for s tandalone  add/edit"R TN","SCCVP CE",160,0)  ; - There  may be no  encounter  yet if we 're just e stimating" RTN","SCCV PCE",161,0 ) ;   ...  it will ne ver get he re without  an encoun ter if con verting"RT N","SCCVPC E",162,0)  I $S('SDOE :1,1:$P($G (^SCE(SDOE ,0)),"^",8 )=2) D  G  PROCQ"RTN" ,"SCCVPCE" ,163,0) .  D GETPROC( .CNT,SDOE, $G(SCDTM), $G(SCDA),S CDXARRY) Q "RTN","SCC VPCE",164, 0) ;"RTN", "SCCVPCE", 165,0) ;-  Use child  encounter( s) for app ointment a nd disposi tion"RTN", "SCCVPCE", 166,0) F   S SDOEC=$O (^SCE("APA R",SDOE,SD OEC)) Q:'S DOEC  I $P ($G(^SCE(S DOEC,0))," ^",8)=2 D  GETPROC(.C NT,SDOEC," ","",SCDXA RRY)"RTN", "SCCVPCE", 167,0) ;"R TN","SCCVP CE",168,0)  ;- Array  of procedu res"RTN"," SCCVPCE",1 69,0)PROCQ  S @SCDXAR RY@(0)=CNT "RTN","SCC VPCE",170, 0) Q"RTN", "SCCVPCE", 171,0) ;"R TN","SCCVP CE",172,0)  ;"RTN","S CCVPCE",17 3,0)GETPRO C(CNT,ENC, SDVDT,EXTR EF,SCDXARR Y) ;Get pr ocedures f rom Schedu ling Visit s file"RTN ","SCCVPCE ",174,0) ; "RTN","SCC VPCE",175, 0) ;"RTN", "SCCVPCE", 176,0) N D ATE,DFN,I, NODE,PRNOD E,SUB"RTN" ,"SCCVPCE" ,177,0) ;" RTN","SCCV PCE",178,0 ) I ENC D   ;Find 'CS ' node fro m encounte r data"RTN ","SCCVPCE ",179,0) .  S NODE=$G (^SCE(ENC, 0)),DATE=+ $P(NODE,"^ "),DFN=+$P (NODE,"^", 2),EXTREF= $P(NODE,"^ ",9)"RTN", "SCCVPCE", 180,0) . S  DATE=$P(D ATE,"."),S DVDT=$$SDV IEN^SCCVU( DFN,DATE)" RTN","SCCV PCE",181,0 ) Q:'$G(SD VDT)"RTN", "SCCVPCE", 182,0) F I =1:1:$L(EX TREF,":")  D  ;Should  not have  > 1 for da tes < 10-1 -96"RTN"," SCCVPCE",1 83,0) . S  SUB=+$P(EX TREF,":",I )"RTN","SC CVPCE",184 ,0) . I '$ D(^SDV(SDV DT,"CS",SU B,0)) Q"RT N","SCCVPC E",185,0)  . I ENC,$P (^SDV(SDVD T,"CS",SUB ,0),U,8)'= ENC Q"RTN" ,"SCCVPCE" ,186,0) .  S CNT=$G(C NT)+$$PRNO DE(SDVDT,S UB,SCDXARR Y)"RTN","S CCVPCE",18 7,0) Q"RTN ","SCCVPCE ",188,0) ; "RTN","SCC VPCE",189, 0)PRNODE(S DVDT,SUB,S CDXARRY) ;  Extract d ata for pr ocs from S DV's 'PR'  node"RTN", "SCCVPCE", 190,0) ; S DVDT -- SD V entry ie n "RTN","S CCVPCE",19 1,0) ; SUB    -- 'CS'  node entr y ien"RTN" ,"SCCVPCE" ,192,0) ;  SCDXARRY - - the name  of the ar ray to ret urn for th e entry"RT N","SCCVPC E",193,0)  ;              SCDXAR RY(0)= the  total # o f procedur e codes"RT N","SCCVPC E",194,0)  ;              SCDXAR RY(CPT cod e) = the t otal # of  a particul ar CPT cod e"RTN","SC CVPCE",195 ,0) N PRNO DE,PCNT,X" RTN","SCCV PCE",196,0 ) S PCNT=0 "RTN","SCC VPCE",197, 0) S PRNOD E=$G(^SDV( +SDVDT,"CS ",+SUB,"PR "))"RTN"," SCCVPCE",1 98,0) I $L (PRNODE,"^ ")<1 G PRQ "RTN","SCC VPCE",199, 0) F X=1:1 :$L(PRNODE ,"^") I $P (PRNODE,"^ ",X)'="" S  PCNT=PCNT +1,@SCDXAR RY@($O(@SC DXARRY@("" ),-1)+1)=$ P(PRNODE," ^",X)"RTN" ,"SCCVPCE" ,200,0)PRQ  Q $G(PCNT )"RTN","SC CVPCE",201 ,0) ;"RTN" ,"SCDXMSG1 ")0^1^B747 96215"RTN" ,"SCDXMSG1 ",1,0)SCDX MSG1 ;ALB/ JRP - AMB  CARE MESSA GE BUILDER  UTILS;08- MAY-1996 ;  6/21/05 2 :08pm"RTN" ,"SCDXMSG1 ",2,0) ;;5 .3;Schedul ing;**44,5 5,70,77,85 ,66,143,14 2,162,172, 180,239,24 5,254,293, 325,387,45 9,472,441, 552,631**; AUG 13, 19 93;Build 5 7"RTN","SC DXMSG1",3, 0) ;"RTN", "SCDXMSG1" ,4,0) ;--  Line tags  for buildi ng HL7 seg ment"RTN", "SCDXMSG1" ,5,0)BLDEV N S VAFEVN =$$EN^VAFH LEVN(EVNTH L7,ENCNDT, VAFSTR,HL( "Q"),HL("F S"))"RTN", "SCDXMSG1" ,6,0) ;SD* 5.3*387 re placed EVN TDATE with  ENCNDT"RT N","SCDXMS G1",7,0) Q "RTN","SCD XMSG1",8,0 )BLDPID K  VAFPID D B LDPID^VAFC QRY(DFN,1, VAFSTR,.VA FPID,.HL)" RTN","SCDX MSG1",9,0)  ;check ma rital/reli gion statu s; rebuild  PID segme nt."RTN"," SCDXMSG1", 10,0) D SE TMAR^SCMSV UT0(.VAFPI D,HL("Q"), HL("FS"),H L("ECH"))" RTN","SCDX MSG1",11,0 ) Q"RTN"," SCDXMSG1", 12,0)BLDZP D S VAFZPD =$$EN1^VAF HLZPD(DFN, VAFSTR)"RT N","SCDXMS G1",13,0)  D SETPOW^S CMSVUT0(DF N,.VAFZPD, HL("Q"),HL ("FS"))"RT N","SCDXMS G1",14,0)  Q"RTN","SC DXMSG1",15 ,0)BLDPV1  D SETID^SC MSVUT0(ENC PTR,DELPTR )"RTN","SC DXMSG1",16 ,0) S VAFP V1=$$EN^VA FHLPV1(ENC PTR,DELPTR ,VAFSTR,1, HL("Q"),HL ("FS"))"RT N","SCDXMS G1",17,0)  Q"RTN","SC DXMSG1",18 ,0)BLDDG1  K @DNS  RY "RTN","SCD XMSG1",19, 0) D EN^VA FHLDG1(ENC PTR,VAFSTR ,HL("Q"),H L("FS"),DN S  RY)"RTN ","SCDXMSG 1",20,0) Q "RTN","SCD XMSG1",21, 0)BLDPR1 K  @DNS  RY" RTN","SCDX MSG1",22,0 ) D SETPRT Y^SCMSVUT0 (ENCPTR)"R TN","SCDXM SG1",23,0)  D EN^VAFH LPR1(ENCPT R,VAFSTR,H L("Q"),HL( "FS"),HL(" ECH"),DNS   RY)"RTN", "SCDXMSG1" ,24,0) Q"R TN","SCDXM SG1",25,0) BLDZEL N E LCOD,ELIGE NC,I,VAFMS TDT"RTN"," SCDXMSG1", 26,0) S VA FMSTDT=ENC DT"RTN","S CDXMSG1",2 7,0) D EN1 ^VAFHLZEL( DFN,VAFSTR ,1,.VAFZEL )"RTN","SC DXMSG1",28 ,0) S ELCO D=$P($G(^S CE(ENCPTR, 0)),"^",13 ),ELIGENC= $P($G(^DIC (8,+ELCOD, 0)),"^",9) "RTN","SCD XMSG1",29, 0) S $P(VA FZEL(1),HL ("FS"),3)= ELIGENC"RT N","SCDXMS G1",30,0)  Q"RTN","SC DXMSG1",31 ,0)BLDZIR  K DGREL,DG INC,DGINR, DGDEP"RTN" ,"SCDXMSG1 ",32,0) D  ALL^DGMTU2 1(DFN,"V", ENCDT,"R") "RTN","SCD XMSG1",33, 0) S VAFZI R=$$EN^VAF HLZIR(+$G( DGINR("V") ),VAFSTR,1 ,ENCPTR)"R TN","SCDXM SG1",34,0)  K DGREL,D GINC,DGINR ,DGDEP"RTN ","SCDXMSG 1",35,0) Q "RTN","SCD XMSG1",36, 0)BLDZCL K  @DNS  RY" RTN","SCDX MSG1",37,0 ) D EN^VAF HLZCL(DFN, ENCPTR,VAF STR,HL("Q" ),HL("FS") ,DNS  RY)" RTN","SCDX MSG1",38,0 ) Q"RTN"," SCDXMSG1", 39,0)BLDZS C K @DNS   RY"RTN","S CDXMSG1",4 0,0) D EN^ VAFHLZSC(E NCPTR,VAFS TR,HL("Q") ,HL("FS"), DNS  RY)"R TN","SCDXM SG1",41,0)  Q"RTN","S CDXMSG1",4 2,0)BLDZSP  S VAFZSP= $$EN^VAFHL ZSP(DFN,1, 1)"RTN","S CDXMSG1",4 3,0) S VAF ZSP=$$SETV SI^SCMSVUT 0(DFN,$G(V AFZSP),HL( "Q"),HL("F S"))"RTN", "SCDXMSG1" ,44,0) Q"R TN","SCDXM SG1",45,0) BLDROL K @ DNS  RY"RT N","SCDXMS G1",46,0)  N SCDXPRV, SCDXPAR,SC DXROL,PTRP RV,NODE,PR VNUM,TMP"R TN","SCDXM SG1",47,0)  D GETPRV^ SDOE(ENCPT R,"SCDXPRV ")"RTN","S CDXMSG1",4 8,0) S PTR PRV=0"RTN" ,"SCDXMSG1 ",49,0) F  PRVNUM=1:1   S PTRPRV =+$O(SCDXP RV(PTRPRV) ) Q:('PTRP RV)  D"RTN ","SCDXMSG 1",50,0) . K SCDXPAR, SCDXROL"RT N","SCDXMS G1",51,0)  .S NODE=SC DXPRV(PTRP RV)"RTN"," SCDXMSG1", 52,0) .S S CDXPAR("PT R200")=+NO DE"RTN","S CDXMSG1",5 3,0) .S SC DXPAR("INS TID")=$$VI D4XMIT^SCD XFU11(XMIT PTR)_"-"_( +NODE)_"*" _PRVNUM"RT N","SCDXMS G1",54,0)  .S SCDXPAR ("ACTION") ="CO""RTN" ,"SCDXMSG1 ",55,0) .S  SCDXPAR(" ALTROLE")= ($TR($P(NO DE,"^",4), "PS","10") )_$E(HL("E CH"),1)_HL ("Q")_$E(H L("ECH"),1 )_"VA01""R TN","SCDXM SG1",56,0)  .S SCDXPA R("CODEONL Y")=0"RTN" ,"SCDXMSG1 ",57,0) .S  SCDXPAR(" RDATE")=EN CDT"RTN"," SCDXMSG1", 58,0) .D O UTPAT^VAFH LROL("SCDX PAR","SCDX ROL",VAFST R,HL("FS") ,HL("ECH") ,HL("Q"),2 40)"RTN"," SCDXMSG1", 59,0) .K S CDXROL("ER ROR"),SCDX ROL("WARNI NG")"RTN", "SCDXMSG1" ,60,0) .M  @DNS  RY@( PRVNUM)=SC DXROL"RTN" ,"SCDXMSG1 ",61,0) Q" RTN","SCDX MSG1",62,0 )BLDPD1 S  VAFPD1=$$E N^VAFHLPD1 (DFN,VAFST R)"RTN","S CDXMSG1",6 3,0) Q"RTN ","SCDXMSG 1",64,0)BL DZEN S VAF ZEN=$$EN^V AFHLZEN(DF N,VAFSTR,1 ,HL("Q"),H L("FS"))"R TN","SCDXM SG1",65,0)  Q"RTN","S CDXMSG1",6 6,0) ;"RTN ","SCDXMSG 1",67,0) ; -- Line ta gs for val idating HL 7 segments "RTN","SCD XMSG1",68, 0)VLDEVN S  ERROR=$$E N^SCMSVEVN (VAFEVN,HL ("Q"),HL(" FS"),VALER R)"RTN","S CDXMSG1",6 9,0) S:(ER ROR>0) ERR OR=0"RTN", "SCDXMSG1" ,70,0) Q"R TN","SCDXM SG1",71,0) VLDPID S E RROR=$$EN^ SCMSVPID(. VAFPID,HL( "Q"),HL("F S"),HL("EC H"),VALERR ,ENCDT,EVN THL7)"RTN" ,"SCDXMSG1 ",72,0) S: (ERROR>0)  ERROR=0"RT N","SCDXMS G1",73,0)  Q"RTN","SC DXMSG1",74 ,0)VLDZPD  S ERROR=$$ EN^SCMSVZP D(.VAFZPD, HL("Q"),HL ("FS"),VAL ERR,ENCDT, NODE)"RTN" ,"SCDXMSG1 ",75,0) S: (ERROR>0)  ERROR=0"RT N","SCDXMS G1",76,0)  Q"RTN","SC DXMSG1",77 ,0)VLDPV1  S ERROR=$$ EN^SCMSVPV 1(VAFPV1,H L("Q"),HL( "FS"),VALE RR,NODE,EV NTHL7,ENCN DT)"RTN"," SCDXMSG1", 78,0) S:(E RROR>0) ER ROR=0"RTN" ,"SCDXMSG1 ",79,0) Q" RTN","SCDX MSG1",80,0 )VLDDG1 S  ERROR=$$EN ^SCMSVDG1( DNS  RY,HL ("Q"),HL(" FS"),ENCPT R,VALERR,E NCDT)"RTN" ,"SCDXMSG1 ",81,0) S: (ERROR>0)  ERROR=0"RT N","SCDXMS G1",82,0)  Q"RTN","SC DXMSG1",83 ,0)VLDPR1  S ERROR=$$ EN^SCMSVPR 1(DNS  RY, HL("Q"),HL ("FS"),HL( "ECH"),VAL ERR,ENCDT) "RTN","SCD XMSG1",84, 0) S:(ERRO R>0) ERROR =0"RTN","S CDXMSG1",8 5,0) Q"RTN ","SCDXMSG 1",86,0)VL DZEL N VAF ZELSV M VA FZELSV=VAF ZEL"RTN"," SCDXMSG1", 87,0) S ER ROR=$$EN^S CMSVZEL(.V AFZELSV,HL ("Q"),HL(" FS"),VALER R,DFN)"RTN ","SCDXMSG 1",88,0) S :(ERROR>0)  ERROR=0"R TN","SCDXM SG1",89,0)  Q"RTN","S CDXMSG1",9 0,0)VLDZIR  S ERROR=$ $EN^SCMSVZ IR(VAFZIR, HL("Q"),HL ("FS"),VAL ERR)"RTN", "SCDXMSG1" ,91,0) S:( ERROR>0) E RROR=0"RTN ","SCDXMSG 1",92,0) Q "RTN","SCD XMSG1",93, 0)VLDZCL S  ERROR=$$E N^SCMSVZCL (DNS  RY,H L("Q"),HL( "FS"),VALE RR,DFN)"RT N","SCDXMS G1",94,0)  S:(ERROR>0 ) ERROR=0" RTN","SCDX MSG1",95,0 ) Q"RTN"," SCDXMSG1", 96,0)VLDZS C S ERROR= $$EN^SCMSV ZSC(DNS  R Y,HL("Q"), HL("FS"),V ALERR,ENCP TR)"RTN"," SCDXMSG1", 97,0) S:(E RROR>0) ER ROR=0"RTN" ,"SCDXMSG1 ",98,0) Q" RTN","SCDX MSG1",99,0 )VLDZSP S  ERROR=$$EN ^SCMSVZSP( VAFZSP,HL( "Q"),HL("F S"),VALERR ,DFN)"RTN" ,"SCDXMSG1 ",100,0) S :(ERROR>0)  ERROR=0"R TN","SCDXM SG1",101,0 ) Q"RTN"," SCDXMSG1", 102,0)VLDR OL S ERROR =$$EN^SCMS VROL(DNS   RY,HL("Q") ,HL("FS"), HL("ECH"), VALERR)"RT N","SCDXMS G1",103,0)  S:(ERROR> 0) ERROR=0 "RTN","SCD XMSG1",104 ,0) Q"RTN" ,"SCDXMSG1 ",105,0)VL DPD1 S ERR OR=0"RTN", "SCDXMSG1" ,106,0) Q" RTN","SCDX MSG1",107, 0)VLDZEN S  ERROR=0"R TN","SCDXM SG1",108,0 ) Q"RTN"," SCDXMSG1", 109,0) ;"R TN","SCDXM SG1",110,0 ) ;-- Line  tags for  copying HL 7 segments  into HL7  message"RT N","SCDXMS G1",111,0) CPYEVN N I "RTN","SCD XMSG1",112 ,0) S @XMI TARRY@(CUR LINE)=VAFE VN"RTN","S CDXMSG1",1 13,0) S LI NESADD=LIN ESADD+1"RT N","SCDXMS G1",114,0)  S I="""RT N","SCDXMS G1",115,0)  F  S I=+$ O(VAFEVN(I )) Q:('I)   D"RTN","S CDXMSG1",1 16,0) .S @ XMITARRY@( CURLINE,I) =VAFEVN(I) "RTN","SCD XMSG1",117 ,0) .S LIN ESADD=LINE SADD+1"RTN ","SCDXMSG 1",118,0)  Q"RTN","SC DXMSG1",11 9,0)CPYPID  N I"RTN", "SCDXMSG1" ,120,0) S  @XMITARRY@ (CURLINE)= VAFPID"RTN ","SCDXMSG 1",121,0)  S LINESADD =LINESADD+ 1"RTN","SC DXMSG1",12 2,0) S I=" ""RTN","SC DXMSG1",12 3,0) F  S  I=+$O(VAFP ID(I)) Q:( 'I)  D"RTN ","SCDXMSG 1",124,0)  .S @XMITAR RY@(CURLIN E,I)=VAFPI D(I)"RTN", "SCDXMSG1" ,125,0) .S  LINESADD= LINESADD+1 "RTN","SCD XMSG1",126 ,0) Q"RTN" ,"SCDXMSG1 ",127,0)CP YZPD N I"R TN","SCDXM SG1",128,0 ) S @XMITA RRY@(CURLI NE)=VAFZPD "RTN","SCD XMSG1",129 ,0) S LINE SADD=LINES ADD+1"RTN" ,"SCDXMSG1 ",130,0) S  I="""RTN" ,"SCDXMSG1 ",131,0) F   S I=+$O( VAFZPD(I))  Q:('I)  D "RTN","SCD XMSG1",132 ,0) .S @XM ITARRY@(CU RLINE,I)=V AFZPD(I)"R TN","SCDXM SG1",133,0 ) .S LINES ADD=LINESA DD+1"RTN", "SCDXMSG1" ,134,0) Q" RTN","SCDX MSG1",135, 0)CPYPV1 N  I"RTN","S CDXMSG1",1 36,0) S @X MITARRY@(C URLINE)=VA FPV1"RTN", "SCDXMSG1" ,137,0) S  LINESADD=L INESADD+1" RTN","SCDX MSG1",138, 0) S I=""" RTN","SCDX MSG1",139, 0) F  S I= +$O(VAFPV1 (I)) Q:('I )  D"RTN", "SCDXMSG1" ,140,0) .S  @XMITARRY @(CURLINE, I)=VAFPV1( I)"RTN","S CDXMSG1",1 41,0) .S L INESADD=LI NESADD+1"R TN","SCDXM SG1",142,0 ) Q"RTN"," SCDXMSG1", 143,0)CPYD G1 N I,J,K "RTN","SCD XMSG1",144 ,0) S I="" "RTN","SCD XMSG1",145 ,0) F K=0: 1 S I=+$O( @DNS  RY@( I)) Q:('I)   D"RTN"," SCDXMSG1", 146,0) .S  J="""RTN", "SCDXMSG1" ,147,0) .F   S J=$O(@ DNS  RY@(I ,J)) Q:(J= "")  D"RTN ","SCDXMSG 1",148,0)  ..S:('J) @ XMITARRY@( CURLINE+K) =@DNS  RY@ (I,J)"RTN" ,"SCDXMSG1 ",149,0) . .S:(J) @XM ITARRY@(CU RLINE+K,J) =@DNS  RY@ (I,J)"RTN" ,"SCDXMSG1 ",150,0) . .S LINESAD D=LINESADD +1"RTN","S CDXMSG1",1 51,0) S CU RLINE=CURL INE+K-1"RT N","SCDXMS G1",152,0)  Q"RTN","S CDXMSG1",1 53,0)CPYPR 1 N I,J,K" RTN","SCDX MSG1",154, 0) S I=""" RTN","SCDX MSG1",155, 0) F K=0:1  S I=+$O(@ DNS  RY@(I )) Q:('I)   D"RTN","S CDXMSG1",1 56,0) .S J ="""RTN"," SCDXMSG1", 157,0) .F   S J=$O(@D NS  RY@(I, J)) Q:(J=" ")  D"RTN" ,"SCDXMSG1 ",158,0) . .S:('J) @X MITARRY@(C URLINE+K)= @DNS  RY@( I,J)"RTN", "SCDXMSG1" ,159,0) .. S:(J) @XMI TARRY@(CUR LINE+K,J)= @DNS  RY@( I,J)"RTN", "SCDXMSG1" ,160,0) .. S LINESADD =LINESADD+ 1"RTN","SC DXMSG1",16 1,0) S CUR LINE=CURLI NE+K-1"RTN ","SCDXMSG 1",162,0)  Q"RTN","SC DXMSG1",16 3,0)CPYZEL  N I"RTN", "SCDXMSG1" ,164,0) S  @XMITARRY@ (CURLINE)= VAFZEL(1)" RTN","SCDX MSG1",165, 0) S LINES ADD=LINESA DD+1"RTN", "SCDXMSG1" ,166,0) S  I="""RTN", "SCDXMSG1" ,167,0) F   S I=+$O(V AFZEL(1,I) ) Q:('I)   D"RTN","SC DXMSG1",16 8,0) .S @X MITARRY@(C URLINE,I)= VAFZEL(1,I )"RTN","SC DXMSG1",16 9,0) .S LI NESADD=LIN ESADD+1"RT N","SCDXMS G1",170,0)  Q"RTN","S CDXMSG1",1 71,0)CPYZI R N I"RTN" ,"SCDXMSG1 ",172,0) S  @XMITARRY @(CURLINE) =VAFZIR"RT N","SCDXMS G1",173,0)  S LINESAD D=LINESADD +1"RTN","S CDXMSG1",1 74,0) N I" RTN","SCDX MSG1",175, 0) S I=""" RTN","SCDX MSG1",176, 0) F  S I= +$O(VAFZIR (I)) Q:('I )  D"RTN", "SCDXMSG1" ,177,0) .S  @XMITARRY @(CURLINE, I)=VAFZIR( I)"RTN","S CDXMSG1",1 78,0) .S L INESADD=LI NESADD+1"R TN","SCDXM SG1",179,0 ) Q"RTN"," SCDXMSG1", 180,0)CPYZ CL N I,J,K "RTN","SCD XMSG1",181 ,0) S I="" "RTN","SCD XMSG1",182 ,0) F K=0: 1 S I=+$O( @DNS  RY@( I)) Q:('I)   D"RTN"," SCDXMSG1", 183,0) .S  J="""RTN", "SCDXMSG1" ,184,0) .F   S J=$O(@ DNS  RY@(I ,J)) Q:(J= "")  D"RTN ","SCDXMSG 1",185,0)  ..S:('J) @ XMITARRY@( CURLINE+K) =@DNS  RY@ (I,J)"RTN" ,"SCDXMSG1 ",186,0) . .S:(J) @XM ITARRY@(CU RLINE+K,J) =@DNS  RY@ (I,J)"RTN" ,"SCDXMSG1 ",187,0) . .S LINESAD D=LINESADD +1"RTN","S CDXMSG1",1 88,0) S CU RLINE=CURL INE+K-1"RT N","SCDXMS G1",189,0)  Q"RTN","S CDXMSG1",1 90,0)CPYZS C N I,J,K" RTN","SCDX MSG1",191, 0) S I=""" RTN","SCDX MSG1",192, 0) F K=0:1  S I=+$O(@ DNS  RY@(I )) Q:('I)   D"RTN","S CDXMSG1",1 93,0) .S J ="""RTN"," SCDXMSG1", 194,0) .F   S J=$O(@D NS  RY@(I, J)) Q:(J=" ")  D"RTN" ,"SCDXMSG1 ",195,0) . .S:('J) @X MITARRY@(C URLINE+K)= @DNS  RY@( I,J)"RTN", "SCDXMSG1" ,196,0) .. S:(J) @XMI TARRY@(CUR LINE+K,J)= @DNS  RY@( I,J)"RTN", "SCDXMSG1" ,197,0) .. S LINESADD =LINESADD+ 1"RTN","SC DXMSG1",19 8,0) S CUR LINE=CURLI NE+K-1"RTN ","SCDXMSG 1",199,0)  Q"RTN","SC DXMSG1",20 0,0)CPYZSP  N I"RTN", "SCDXMSG1" ,201,0) S  @XMITARRY@ (CURLINE)= VAFZSP"RTN ","SCDXMSG 1",202,0)  S LINESADD =LINESADD+ 1"RTN","SC DXMSG1",20 3,0) S I=" ""RTN","SC DXMSG1",20 4,0) F  S  I=+$O(VAFZ SP(I)) Q:( 'I)  D"RTN ","SCDXMSG 1",205,0)  .S @XMITAR RY@(CURLIN E,I)=VAFZS P(I)"RTN", "SCDXMSG1" ,206,0) .S  LINESADD= LINESADD+1 "RTN","SCD XMSG1",207 ,0) Q"RTN" ,"SCDXMSG1 ",208,0)CP YROL N I,J ,K"RTN","S CDXMSG1",2 09,0) S I= """RTN","S CDXMSG1",2 10,0) F K= 0:1 S I=+$ O(@DNS  RY @(I)) Q:(' I)  D"RTN" ,"SCDXMSG1 ",211,0) . S J="""RTN ","SCDXMSG 1",212,0)  .F  S J=$O (@DNS  RY@ (I,J)) Q:( J="")  D"R TN","SCDXM SG1",213,0 ) ..S:('J)  @XMITARRY @(CURLINE+ K)=@DNS  R Y@(I,J)"RT N","SCDXMS G1",214,0)  ..S:(J) @ XMITARRY@( CURLINE+K, J)=@DNS  R Y@(I,J)"RT N","SCDXMS G1",215,0)  ..S LINES ADD=LINESA DD+1"RTN", "SCDXMSG1" ,216,0) S  CURLINE=CU RLINE+K-1" RTN","SCDX MSG1",217, 0) Q"RTN", "SCDXMSG1" ,218,0)CPY PD1 N I"RT N","SCDXMS G1",219,0)  S @XMITAR RY@(CURLIN E)=VAFPD1" RTN","SCDX MSG1",220, 0) S LINES ADD=LINESA DD+1"RTN", "SCDXMSG1" ,221,0) S  I="""RTN", "SCDXMSG1" ,222,0) F   S I=+$O(V AFPD1(I))  Q:('I)  D" RTN","SCDX MSG1",223, 0) .S @XMI TARRY@(CUR LINE,I)=VA FPD1(I)"RT N","SCDXMS G1",224,0)  .S LINESA DD=LINESAD D+1"RTN"," SCDXMSG1", 225,0) Q"R TN","SCDXM SG1",226,0 )CPYZEN N  I"RTN","SC DXMSG1",22 7,0) S @XM ITARRY@(CU RLINE)=VAF ZEN"RTN"," SCDXMSG1", 228,0) S L INESADD=LI NESADD+1"R TN","SCDXM SG1",229,0 ) S I="""R TN","SCDXM SG1",230,0 ) F  S I=+ $O(VAFZEN( I)) Q:('I)   D"RTN"," SCDXMSG1", 231,0) .S  @XMITARRY@ (CURLINE,I )=VAFZEN(I )"RTN","SC DXMSG1",23 2,0) .S LI NESADD=LIN ESADD+1"RT N","SCDXMS G1",233,0)  Q"RTN","S CDXMSG1",2 34,0) ;"RT N","SCDXMS G1",235,0)  ;-- Line  tags for d eleting HL 7 segments "RTN","SCD XMSG1",236 ,0)DELEVN  K VAFEVN"R TN","SCDXM SG1",237,0 ) Q"RTN"," SCDXMSG1", 238,0)DELP ID K VAFPI D"RTN","SC DXMSG1",23 9,0) Q"RTN ","SCDXMSG 1",240,0)D ELZPD K VA FZPD"RTN", "SCDXMSG1" ,241,0) Q" RTN","SCDX MSG1",242, 0)DELPV1 K  VAFPV1"RT N","SCDXMS G1",243,0)  Q"RTN","S CDXMSG1",2 44,0)DELDG 1 K @DNS   RY"RTN","S CDXMSG1",2 45,0) Q"RT N","SCDXMS G1",246,0) DELPR1 K @ DNS  RY"RT N","SCDXMS G1",247,0)  Q"RTN","S CDXMSG1",2 48,0)DELZE L K VAFZEL "RTN","SCD XMSG1",249 ,0) Q"RTN" ,"SCDXMSG1 ",250,0)DE LZIR K VAF ZIR"RTN"," SCDXMSG1", 251,0) Q"R TN","SCDXM SG1",252,0 )DELZCL K  @DNS  RY"R TN","SCDXM SG1",253,0 ) Q"RTN"," SCDXMSG1", 254,0)DELZ SC K @DNS   RY"RTN"," SCDXMSG1", 255,0) Q"R TN","SCDXM SG1",256,0 )DELZSP K  VAFZSP"RTN ","SCDXMSG 1",257,0)  Q"RTN","SC DXMSG1",25 8,0)DELROL  K @DNS  R Y"RTN","SC DXMSG1",25 9,0) Q"RTN ","SCDXMSG 1",260,0)D ELPD1 K VA FPD1"RTN", "SCDXMSG1" ,261,0) Q" RTN","SCDX MSG1",262, 0)DELZEN K  VAFZEN"RT N","SCDXMS G1",263,0)  Q"RTN","S CDXMSG1",2 64,0) ;"RT N","SCDXMS G1",265,0)  ;"RTN","S CDXMSG1",2 66,0)SEGME NTS(EVNTTY PE,SEGARRY ) ;Build l ist of HL7  segments  for a give n"RTN","SC DXMSG1",26 7,0) ; eve nt type"RT N","SCDXMS G1",268,0)  ;"RTN","S CDXMSG1",2 69,0) ;Inp ut  : EVNT TYPE - Eve nt type to  build lis t for"RTN" ,"SCDXMSG1 ",270,0) ;                       A08 & A23  are the on ly types c urrently s upported"R TN","SCDXM SG1",271,0 ) ;                      (Defaul ts to A08) "RTN","SCD XMSG1",272 ,0) ;          SEGARR Y - Array  to place o utput in ( full globa l referenc e)"RTN","S CDXMSG1",2 73,0) ;                     (Def aults to ^ TMP("SCDX  SEGMENTS", $J))"RTN", "SCDXMSG1" ,274,0) ;O utput : No ne"RTN","S CDXMSG1",2 75,0) ;            SE GARRY(Seq, Name) = Fi elds"RTN", "SCDXMSG1" ,276,0) ;               Seq - Se quencing n umber to o rder the s egments as "RTN","SCD XMSG1",277 ,0) ;                     they s hould be p laced in t he HL7 mes sage"RTN", "SCDXMSG1" ,278,0) ;               Name - N ame of HL7  segment"R TN","SCDXM SG1",279,0 ) ;              Fiel ds - List  of fields  used by Am bulatory C are"RTN"," SCDXMSG1", 280,0) ;                         VAFSTR wou ld be set  to this va lue"RTN"," SCDXMSG1", 281,0) ;        : MSH  segment i s not incl uded"RTN", "SCDXMSG1" ,282,0) ;" RTN","SCDX MSG1",283, 0) ;Check  input"RTN" ,"SCDXMSG1 ",284,0) S  EVNTTYPE= $G(EVNTTYP E)"RTN","S CDXMSG1",2 85,0) S:(E VNTTYPE'=" A23") EVNT TYPE="A08" "RTN","SCD XMSG1",286 ,0) S SEGA RRY=$G(SEG ARRY)"RTN" ,"SCDXMSG1 ",287,0) S :(SEGARRY= "") SEGARR Y="^TMP("" SCDX SEGME NTS"","_$J _")""RTN", "SCDXMSG1" ,288,0) ;S egments us ed by A08  & A23"RTN" ,"SCDXMSG1 ",289,0) S  @SEGARRY@ (1,"EVN")= "1,2""RTN" ,"SCDXMSG1 ",290,0) S  @SEGARRY@ (2,"PID")= "1,2,3,4,5 ,6,7,8,10, 11,13,14,1 6,17,19,22 ""RTN","SC DXMSG1",29 1,0) S @SE GARRY@(3," PD1")="3,4 ""RTN","SC DXMSG1",29 2,0) S @SE GARRY@(4," PV1")="1,2 ,4,14,19,3 9,44,50""R TN","SCDXM SG1",293,0 ) ;Buildin g list for  A23 - add  ZPD segme nt and qui t"RTN","SC DXMSG1",29 4,0) I (EV NTTYPE="A2 3") D  Q"R TN","SCDXM SG1",295,0 ) .S @SEGA RRY@(5,"ZP D")="1,2,3 ,4,5,6,7,8 ,9,10,11,1 2,13,14,15 ,16,17,18, 19,20,21,4 0""RTN","S CDXMSG1",2 96,0) S @S EGARRY@(5, "DG1")="1, 2,3,4,5,15 ""RTN","SC DXMSG1",29 7,0) S @SE GARRY@(6," PR1")="1,3 ,16""RTN", "SCDXMSG1" ,298,0) S  @SEGARRY@( 7,"ROL")=" 1,2,3,4""R TN","SCDXM SG1",299,0 ) S @SEGAR RY@(8,"ZPD ")="1,2,3, 4,5,6,7,8, 9,10,11,12 ,13,14,15, 16,17,18,1 9,20,21,40 ""RTN","SC DXMSG1",30 0,0) ;Segm ent used f or ZEL add ed Camp Le jeune Fiel ds SD*5.3* 631 JLS"RT N","SCDXMS G1",301,0)  S @SEGARR Y@(9,"ZEL" )="1,2,3,4 ,5,6,7,8,9 ,10,11,12, 13,14,15,1 6,17,18,19 ,20,21,22, 23,24,29,3 7,38,40,41 ,42,43,44" "RTN","SCD XMSG1",302 ,0) S @SEG ARRY@(10," ZIR")="1,2 ,3,4,5,6,7 ,8,9,10,11 ,12,13""RT N","SCDXMS G1",303,0)  S @SEGARR Y@(11,"ZCL ")="1,2,3" "RTN","SCD XMSG1",304 ,0) S @SEG ARRY@(12," ZSC")="1,2 ,3""RTN"," SCDXMSG1", 305,0) S @ SEGARRY@(1 3,"ZSP")=" 1,2,3,4""R TN","SCDXM SG1",306,0 ) S @SEGAR RY@(14,"ZE N")="1,2,3 ,4,5,6,7,8 ,9,10""RTN ","SCDXMSG 1",307,0)  Q"RTN","SC DXMSG1",30 8,0) ;"RTN ","SCDXMSG 1",309,0)U NWIND(XMIT ARRY,INSRT PNT) ;Remo ve all dat a that was  put into  HL7 messag e"RTN","SC DXMSG1",31 0,0) ;"RTN ","SCDXMSG 1",311,0)  ;Input  :  XMITARRY -  Array con taining HL 7 message  (full glob al ref)"RT N","SCDXMS G1",312,0)  ;                      (Default s to ^TMP( "HLS",$J)) "RTN","SCD XMSG1",313 ,0) ;          INSRTP NT - Where  to begin  deletion f rom (Defau lts to 1)" RTN","SCDX MSG1",314, 0) ;Output  : None"RT N","SCDXMS G1",315,0)  ;"RTN","S CDXMSG1",3 16,0) ;Che ck input"R TN","SCDXM SG1",317,0 ) S XMITAR RY=$G(XMIT ARRY)"RTN" ,"SCDXMSG1 ",318,0) S :(XMITARRY ="") XMITA RRY="^TMP( ""HLS"","_ $J_")""RTN ","SCDXMSG 1",319,0)  S INSRTPNT =$G(INSRTP NT)"RTN"," SCDXMSG1", 320,0) S:( INSRTPNT=" ") INSRTPN T=1"RTN"," SCDXMSG1", 321,0) ;Re move inser tion point  from arra y"RTN","SC DXMSG1",32 2,0) K @XM ITARRY@(IN SRTPNT)"RT N","SCDXMS G1",323,0)  ;Remove e verything  from inser tion point  to end of  array"RTN ","SCDXMSG 1",324,0)  F  S INSRT PNT=$O(@XM ITARRY@(IN SRTPNT)) Q :(INSRTPNT ="")  K @X MITARRY@(I NSRTPNT)"R TN","SCDXM SG1",325,0 ) ;Done"RT N","SCDXMS G1",326,0)  Q"RTN","S CDXUTL0")0 ^2^B387003 88"RTN","S CDXUTL0",1 ,0)SCDXUTL 0 ;ALB/ESD / - Generi c function s for Amb  Care HL7 I nterface ;  5/31/05 1 1:23am"RTN ","SCDXUTL 0",2,0) ;; 5.3;Schedu ling;**44, 55,69,77,8 5,110,122, 94,66,132, 180,235,25 6,258,325, 451,441,56 2,585,631* *;Aug 13,  1993;Build  57"RTN"," SCDXUTL0", 3,0) ;"RTN ","SCDXUTL 0",4,0) ;  This routi ne contain s function s used wit h the Ambu latory Car e"RTN","SC DXUTL0",5, 0) ; Repor ting Proje ct (ACRP). "RTN","SCD XUTL0",6,0 ) ;"RTN"," SCDXUTL0", 7,0) ;ICR  Agreements :"RTN","SC DXUTL0",8, 0) ;"RTN", "SCDXUTL0" ,9,0) ;ICR  - 3481 fo r referenc e to $$SC^ DGMTR"RTN" ,"SCDXUTL0 ",10,0) ;I CR - 2463  for refere nce to $$L ST^DGMTU"R TN","SCDXU TL0",11,0)  ;ICR - 36 37 for ref erence to  $$PA^DGMTU TL"RTN","S CDXUTL0",1 2,0) ;"RTN ","SCDXUTL 0",13,0) ; "RTN","SCD XUTL0",14, 0)MTI(DFN, DATE,EC,AT ,SDOE) ;Ca lculate Me ans Test I ndicator"R TN","SCDXU TL0",15,0)  ;"RTN","S CDXUTL0",1 6,0) ;     Input:      DFN   =   Patient IE N"RTN","SC DXUTL0",17 ,0) ;                 Date  =  E ncounter D ate/Time"R TN","SCDXU TL0",18,0)  ;                EC     =  Elig ibility (C ode) of En counter"RT N","SCDXUT L0",19,0)  ;                AT     =  Appoi ntment Typ e of Encou nter"RTN", "SCDXUTL0" ,20,0) ;                 SDOE  =   Outpatie nt Encount er IEN"RTN ","SCDXUTL 0",21,0) ; "RTN","SCD XUTL0",22, 0) ;   Out put:     M TI   =  Me ans Test I ndicator"R TN","SCDXU TL0",23,0)  ;"RTN","S CDXUTL0",2 4,0) N MT, MTI,SDVD1, SDINPT,SDA NS,SDANS1, SDINPT,SDM T,VET,X"RT N","SCDXUT L0",25,0)  S MTI="""R TN","SCDXU TL0",26,0)  S DFN=$G( DFN),DATE= $G(DATE),E C=$G(EC),A T=$G(AT),S DOE=$G(SDO E)"RTN","S CDXUTL0",2 7,0) I (DF N="")!(DAT E="")!(EC= "")!(EC=0) !(AT="")!( SDOE="") G  MTQ"RTN", "SCDXUTL0" ,28,0) I ' $D(^DIC(8, +EC,0)) Q  MTI   ;SD* 585"RTN"," SCDXUTL0", 29,0) ;"RT N","SCDXUT L0",30,0)  ;- VA Code  (get from  MAS Eligi bility Cod e IEN)"RTN ","SCDXUTL 0",31,0) S  X=$G(^DIC (8.1,$P($G (^DIC(8,+E C,0)),"^", 9),0))"RTN ","SCDXUTL 0",32,0) S  EC=$P(X," ^",4),VET= $P(X,"^",5 )"RTN","SC DXUTL0",33 ,0) ;- Non -Veteran"R TN","SCDXU TL0",34,0)  I $P($G(^ DPT(DFN,"V ET")),"^") ="N"!(VET= "N") S MTI ="N" G MTQ "RTN","SCD XUTL0",35, 0) ;- Dom  patient"RT N","SCDXUT L0",36,0)  I EC=6 S M TI="X" G M TQ"RTN","S CDXUTL0",3 7,0) ;- In patient st atus"RTN", "SCDXUTL0" ,38,0) S S DVD1=DATE  D INPT^SDO PC1 I SDMT ="X0" S MT I="X" G MT Q"RTN","SC DXUTL0",39 ,0) ;- Ser vice Conne cted > 50  %"RTN","SC DXUTL0",40 ,0) I EC=1  S MTI="AS " G MTQ"RT N","SCDXUT L0",41,0)  ;-- Servic e Connecte d < 50 %"R TN","SCDXU TL0",42,0)  I EC=3,$$ SC^DGMTR(D FN) D  I M TI'="" G M TQ"RTN","S CDXUTL0",4 3,0) .; 'A S' if seen  for SC co ndition"RT N","SCDXUT L0",44,0)  .I $P($G(^ SDD(409.42 ,+$O(^SDD( 409.42,"AO ",+SDOE,3, 0)),0)),U, 3) S MTI=" AS""RTN"," SCDXUTL0", 45,0) ;-Mi litary Dis ability Re tiree"RTN" ,"SCDXUTL0 ",46,0) ;S  X=$P($G(^ DPT(DFN,.3 6)),"^",2)  I X,(X<3)  S MTI="AS " G MTQ"RT N","SCDXUT L0",47,0)  ;-Military  Disabilit y Retireme nt OR Disc harge Due  To Disabil ity"RTN"," SCDXUTL0", 48,0) I $P ($G(^DPT(D FN,.36))," ^",12)!($P ($G(^DPT(D FN,.36))," ^",13)) S  MTI="AS" G  MTQ"RTN", "SCDXUTL0" ,49,0) ;"R TN","SCDXU TL0",50,0)  I EC=2 D   I MTI'=""  G MTQ"RTN ","SCDXUTL 0",51,0) . ;- Mexican  Border Pe riod or Wo rld War I" RTN","SCDX UTL0",52,0 ) .I $P($G (^DIC(21,+ $P($G(^DPT (DFN,.32)) ,"^",3),0) ),"^",3)=1 !($P($G(^D IC(21,+$P( $G(^DPT(DF N,.32)),"^ ",3),0))," ^",3)=3) S  MTI="AS"  Q"RTN","SC DXUTL0",53 ,0) .;- Pr isoner of  War (POW)" RTN","SCDX UTL0",54,0 ) .I $P($G (^DPT(DFN, .52)),"^", 5)="Y" S M TI="AS" Q" RTN","SCDX UTL0",55,0 ) .;- Purp le Heart R ecipient"R TN","SCDXU TL0",56,0)  .I $P($G( ^DPT(DFN,. 53)),"^")= "Y" S MTI= "AS" Q"RTN ","SCDXUTL 0",57,0) . ;- Aid and  Attendanc e"RTN","SC DXUTL0",58 ,0) .I $P( $G(^DPT(DF N,.362))," ^",12)="Y"  S MTI="AN " Q"RTN"," SCDXUTL0", 59,0) .;-  Housebound "RTN","SCD XUTL0",60, 0) .I $P($ G(^DPT(DFN ,.362)),"^ ",13)="Y"  S MTI="AN"  Q"RTN","S CDXUTL0",6 1,0) ;- Re ceiving VA  Pension"R TN","SCDXU TL0",62,0)  I EC=4,$P ($G(^DPT(D FN,.362)), "^",14)="Y " S MTI="A N" G MTQ"R TN","SCDXU TL0",63,0)  ;"RTN","S CDXUTL0",6 4,0) I EC= 5!(EC=3) D   I MTI'=" " G MTQ"RT N","SCDXUT L0",65,0)  .;- Eligib le for Med icaid"RTN" ,"SCDXUTL0 ",66,0) .I  $P($G(^DP T(DFN,.38) ),"^")=1 S  MTI="AN"  Q"RTN","SC DXUTL0",67 ,0) .;- Ap pt types w ith ignore  billing s et to 1 (e xcept comp  gen)"RTN" ,"SCDXUTL0 ",68,0) .I  AT'=10,$P ($G(^SD(40 9.1,+AT,0) ),"^",2) S  MTI="X" Q "RTN","SCD XUTL0",69, 0) .;- Tre atment for  AO, IR, E C, MST, HN C, CLV        ;SD*5.3 *631"RTN", "SCDXUTL0" ,70,0) .F  SDANS1=1,2 ,4,5,6,9 S  SDANS=$S( '$D(^SDD(4 09.42,"AO" ,+SDOE,SDA NS1)):"",$ P($G(^SDD( 409.42,$O( ^(SDANS1,0 )),0)),"^" ,3):1,1:0)  I SDANS=1  S MTI="AS " Q"RTN"," SCDXUTL0", 71,0) .I M TI]"" Q"RT N","SCDXUT L0",72,0)  .;- Means  Test Code  A, C, or G   (also Pe nding Adj  = Code C o r Code G)" RTN","SCDX UTL0",73,0 ) .S MT=$$ LST^DGMTU( DFN,DATE)" RTN","SCDX UTL0",74,0 ) .I $P(MT ,"^",4)="A " S MTI="A N" Q"RTN", "SCDXUTL0" ,75,0) .I  $P(MT,"^", 4)="C" S M TI="C" Q"R TN","SCDXU TL0",76,0)  .I $P(MT, "^",4)="G"  S MTI="G"  Q"RTN","S CDXUTL0",7 7,0) .I $P (MT,"^",4) ="P" D  Q" RTN","SCDX UTL0",78,0 ) . .S MTI =$$PA^DGMT UTL($P(MT, "^")),MTI= $S('$D(MTI ):"U",MTI= "MT":"C",M TI="GMT":" G",1:"U")" RTN","SCDX UTL0",79,0 ) .;- no m eans test  status or  no longer  required.. .check cur rent eligi bility dat a"RTN","SC DXUTL0",80 ,0) .S X=+ $G(^DPT(DF N,.36)),X= +$P($G(^DI C(8,X,0)), U,9) ; get  MAS eligi bility"RTN ","SCDXUTL 0",81,0) . ;- Service  connected  > 50 %"RT N","SCDXUT L0",82,0)  .I X=1 S M TI="AS" Q" RTN","SCDX UTL0",83,0 ) .;- Serv ice connec ted < 50 % "RTN","SCD XUTL0",84, 0) .I EC=3 ,'$$SC^DGM TR(DFN) S  MTI="AS" Q "RTN","SCD XUTL0",85, 0) .;- mex  border or  WWI or PO W"RTN","SC DXUTL0",86 ,0) .I X=1 6!(X=17)!( X=18)!(X=2 2) S MTI=" AS" Q"RTN" ,"SCDXUTL0 ",87,0) .; - A&A or P ension or  HB"RTN","S CDXUTL0",8 8,0) .I X= 2!(X=4)!(X =15) S MTI ="AN" Q"RT N","SCDXUT L0",89,0)  ;- Means T est requir ed and not  done/comp leted"RTN" ,"SCDXUTL0 ",90,0) S  MTI="U""RT N","SCDXUT L0",91,0)M TQ Q MTI"R TN","SCDXU TL0",92,0)  ;"RTN","S CDXUTL0",9 3,0) ;"RTN ","SCDXUTL 0",94,0)PA TCLASS(DFN ,SDOE) ; -  Return cl assificati on questio ns from PA TIENT (#2)  file"RTN" ,"SCDXUTL0 ",95,0) ;             (Agent Ora nge, Radia tion Expos ure, Servi ce Connect ed,"RTN"," SCDXUTL0", 96,0) ;             E nvironment al Contami nants, Mil itary Sexu al Trauma  and"RTN"," SCDXUTL0", 97,0) ;             H ead/Neck C ancer ques tions, Cam p Lejeune) "RTN","SCD XUTL0",98, 0) ;"RTN", "SCDXUTL0" ,99,0) ;    Input:  D FN  = Pati ent IEN (f rom file # 2)"RTN","S CDXUTL0",1 00,0) ;            SD OE = Outpa tient Enco unter File  IEN [Opti onal]"RTN" ,"SCDXUTL0 ",101,0) ; "RTN","SCD XUTL0",102 ,0) ;  Out put:  Stri ng contain ing Y if c lassificat ion questi on = YES,  N if "RTN" ,"SCDXUTL0 ",103,0) ;             = NO, nul l otherwis e (classif ications s eparated b y "^")"RTN ","SCDXUTL 0",104,0)  ;"RTN","SC DXUTL0",10 5,0) N NOD E,PATCLASS ,SDTEMP,X" RTN","SCDX UTL0",106, 0) S SDTEM P(1)=$$AO^ SDCO22(DFN ,$G(SDOE)) "RTN","SCD XUTL0",107 ,0) S SDTE MP(2)=$$IR ^SDCO22(DF N,$G(SDOE) )"RTN","SC DXUTL0",10 8,0) S SDT EMP(3)=$$S C^SDCO22(D FN,$G(SDOE ))"RTN","S CDXUTL0",1 09,0) S SD TEMP(4)=$$ EC^SDCO22( DFN,$G(SDO E))"RTN"," SCDXUTL0", 110,0) S S DTEMP(5)=$ $MST^SDCO2 2(DFN,$G(S DOE))"RTN" ,"SCDXUTL0 ",111,0) S  SDTEMP(6) =$$HNC^SDC O22(DFN,$G (SDOE))"RT N","SCDXUT L0",112,0)  S SDTEMP( 7)=$$CV^SD CO22(DFN,$ G(SDOE))"R TN","SCDXU TL0",113,0 ) S SDTEMP (8)=$$SHAD ^SDCO22(DF N)"RTN","S CDXUTL0",1 14,0) S SD TEMP(9)=$$ CLV^SDCO22 (DFN,$G(SD OE))                           ;  SD - 631    Added Ca mp Lejeune "RTN","SCD XUTL0",115 ,0) F X=1: 1:9 S $P(P ATCLASS,U, X)=$S(SDTE MP(X)=1:"Y ",1:"N")"R TN","SCDXU TL0",116,0 ) Q PATCLA SS"RTN","S CDXUTL0",1 17,0) ;"RT N","SCDXUT L0",118,0)  ;"RTN","S CDXUTL0",1 19,0)CLASS (SDOE,SCDX ARRY) ; -  Return arr ay of clas sification  types for  encounter "RTN","SCD XUTL0",120 ,0) ;"RTN" ,"SCDXUTL0 ",121,0) ;    Input:   SDOE = Ou tpatient E ncounter I EN (from f ile #409.6 8)"RTN","S CDXUTL0",1 22,0) ;"RT N","SCDXUT L0",123,0)  ;  Output :  Array ( pass desir ed name as  parameter ) containi ng"RTN","S CDXUTL0",1 24,0) ;            Cl assificati on Type^Va lue"RTN"," SCDXUTL0", 125,0) ;"R TN","SCDXU TL0",126,0 ) N CLASS, I,X"RTN"," SCDXUTL0", 127,0) S C LASS="",(I ,X)=0"RTN" ,"SCDXUTL0 ",128,0) S  SDOE=+$G( SDOE)"RTN" ,"SCDXUTL0 ",129,0) F   S CLASS= +$O(^SDD(4 09.42,"OE" ,SDOE,CLAS S)) Q:'CLA SS  D"RTN" ,"SCDXUTL0 ",130,0) .  S I=$P($G (^SDD(409. 42,CLASS,0 )),"^"),X= X+1"RTN"," SCDXUTL0", 131,0) . S  @SCDXARRY @(I)=$P($G (^SDD(409. 42,CLASS,0 )),"^")_"^ "_$P($G(^S DD(409.42, CLASS,0)), "^",3)"RTN ","SCDXUTL 0",132,0)C LASSQ S @S CDXARRY@(0 )=X"RTN"," SCDXUTL0", 133,0) Q"R TN","SCDXU TL0",134,0 ) ;"RTN"," SCDXUTL0", 135,0) ;"R TN","SCDXU TL0",136,0 )CHKCLASS( DFN,SDOE)  ; - Get cl assificati on data fo r HL7 VAFH LZCL segme nt"RTN","S CDXUTL0",1 37,0) ;"RT N","SCDXUT L0",138,0)  ;   Input :  DFN = P atient IEN  (from fil e #2)"RTN" ,"SCDXUTL0 ",139,0) ;            SDOE = Out patient En counter IE N (from fi le #409.68 )"RTN","SC DXUTL0",14 0,0) ;"RTN ","SCDXUTL 0",141,0)  ;  Output:   String s eparated b y "^" cont aining: "R TN","SCDXU TL0",142,0 ) ;            1 (pat ient class  = YES and  encounter  class = Y ES)"RTN"," SCDXUTL0", 143,0) ;            0  (patient  class = YE S and enco unter clas s = NO)"RT N","SCDXUT L0",144,0)  ;            HLQ ("" """") othe rwise"RTN" ,"SCDXUTL0 ",145,0) ; "RTN","SCD XUTL0",146 ,0)EN N OE CLASS,OUT, PATCLASS,T YPE,ENCVAL ,CLCNT,PAT VAL"RTN"," SCDXUTL0", 147,0) S P ATCLASS=$$ PATCLASS(D FN,SDOE)"R TN","SCDXU TL0",148,0 ) D CLASS( SDOE,"OECL ASS")"RTN" ,"SCDXUTL0 ",149,0) S  CLCNT=$L( PATCLASS," ^")"RTN"," SCDXUTL0", 150,0) F T YPE=1:1:CL CNT D"RTN" ,"SCDXUTL0 ",151,0) . S ENCVAL=$ P($G(OECLA SS(TYPE)), "^",2)"RTN ","SCDXUTL 0",152,0)  .S PATVAL= $P(PATCLAS S,"^",TYPE )"RTN","SC DXUTL0",15 3,0) .S $P (OUT,"^",T YPE)=""""" ""RTN","SC DXUTL0",15 4,0) .I PA TVAL="Y" S  $P(OUT,"^ ",TYPE)=EN CVAL"RTN", "SCDXUTL0" ,155,0)ENQ  Q OUT"RTN ","SCDXUTL 0",156,0)  ;"RTN","SC DXUTL0",15 7,0) ;"RTN ","SCDXUTL 0",158,0)P OV(DFN,DAT E,CLINIC,A PTYP) ; -  Determine  Purpose of  Visit for  encounter "RTN","SCD XUTL0",159 ,0) ;"RTN" ,"SCDXUTL0 ",160,0) ;    Input:   DFN = Pat ient IEN"R TN","SCDXU TL0",161,0 ) ;           DATE =  Appointmen t Date/Tim e"RTN","SC DXUTL0",16 2,0) ;         CLINIC  = Clinic" RTN","SCDX UTL0",163, 0) ;          APTYP =  Appointme nt Type"RT N","SCDXUT L0",164,0)  ;"RTN","S CDXUTL0",1 65,0) ;  O utput:  Pu rpose of V isit value  (combinat ion of Pur pose of Vi sit"RTN"," SCDXUTL0", 166,0) ;            a nd Appoint ment Type) "RTN","SCD XUTL0",167 ,0) ;"RTN" ,"SCDXUTL0 ",168,0) N  POV,SCDXP OV"RTN","S CDXUTL0",1 69,0) I (D FN=""!(DAT E="")!(CLI NIC="")!(A PTYP=""))  G POVQ"RTN ","SCDXUTL 0",170,0)  I $P($G(^D PT(DFN,"S" ,+DATE,0)) ,"^")'=CLI NIC G POVQ "RTN","SCD XUTL0",171 ,0) S POV= $P($G(^DPT (DFN,"S",+ DATE,0))," ^",7),POV= $S($L(POV) =1:"0"_POV ,1:POV)"RT N","SCDXUT L0",172,0)  S APTYP=$ S($L(APTYP )=1:"0"_AP TYP,1:APTY P)"RTN","S CDXUTL0",1 73,0) S SC DXPOV=POV_ APTYP"RTN" ,"SCDXUTL0 ",174,0)PO VQ Q $G(SC DXPOV)"RTN ","SCDXUTL 0",175,0)  ;"RTN","SC DXUTL0",17 6,0) ;"RTN ","SCDXUTL 0",177,0)S CODE(SDOE, SCDXARRY)  ; Return a rray of st op codes f or encount er"RTN","S CDXUTL0",1 78,0) ;"RT N","SCDXUT L0",179,0)  ;   Input :  SDOE =  Outpatient  Encounter  IEN (from  file #409 .68)"RTN", "SCDXUTL0" ,180,0) ;" RTN","SCDX UTL0",181, 0) ;  Outp ut:  Array  (pass des ired name  as paramet er) contai ning"RTN", "SCDXUTL0" ,182,0) ;             stop codes "RTN","SCD XUTL0",183 ,0) ;"RTN" ,"SCDXUTL0 ",184,0) ; "RTN","SCD XUTL0",185 ,0) N CNT, I,SDOE0,SD OEC,SDOEC0 "RTN","SCD XUTL0",186 ,0) S CNT= 1,(I,SDOEC )=0"RTN"," SCDXUTL0", 187,0) S S DOE=+$G(SD OE)"RTN"," SCDXUTL0", 188,0) I ' $D(^SCE(SD OE,0)) G S CODEQ"RTN" ,"SCDXUTL0 ",189,0) I  '$P($G(^S CE(SDOE,0) ),"^",3) G  SCODEQ"RT N","SCDXUT L0",190,0)  S SDOE0=$ G(^SCE(SDO E,0))"RTN" ,"SCDXUTL0 ",191,0) ; "RTN","SCD XUTL0",192 ,0) ;- Get  stop code  from pare nt encount er"RTN","S CDXUTL0",1 93,0) I $P (SDOE0,"^" ,3) S @SCD XARRY@(CNT )=$P(SDOE0 ,"^",3),I= CNT"RTN"," SCDXUTL0", 194,0) ;"R TN","SCDXU TL0",195,0 ) ;- Get s top code f rom child  encounter  (credit st op)"RTN"," SCDXUTL0", 196,0) F   S SDOEC=+$ O(^SCE("AP AR",SDOE,S DOEC)) Q:( 'SDOEC)!(C NT=2)  D"R TN","SCDXU TL0",197,0 ) . S SDOE C0=$G(^SCE (SDOEC,0)) "RTN","SCD XUTL0",198 ,0) . I $P (SDOEC0,"^ ",3),($P(S DOEC0,"^", 8)=4) D"RT N","SCDXUT L0",199,0)  .. S CNT= CNT+1,I=CN T"RTN","SC DXUTL0",20 0,0) .. S  @SCDXARRY@ (CNT)=$P(S DOEC0,"^", 3)"RTN","S CDXUTL0",2 01,0)SCODE Q S @SCDXA RRY@(0)=I" RTN","SCDX UTL0",202, 0) Q"RTN", "SCDXUTL0" ,203,0) ;" RTN","SCDX UTL0",204, 0) ;"RTN", "SCDXUTL0" ,205,0)PRO C(SDOE,SCD XARRY) ; R eturn arra y of proce dures for  encounter" RTN","SCDX UTL0",206, 0) ;"RTN", "SCDXUTL0" ,207,0) ;" RTN","SCDX UTL0",208, 0) ;   Inp ut:  SDOE  = Outpatie nt Encount er IEN (fr om file #4 09.68)"RTN ","SCDXUTL 0",209,0)  ;"RTN","SC DXUTL0",21 0,0) ;  Ou tput:  Arr ay (pass d esired nam e as param eter) cont aining"RTN ","SCDXUTL 0",211,0)  ;            procedur es"RTN","S CDXUTL0",2 12,0) ;"RT N","SCDXUT L0",213,0)  N CNT"RTN ","SCDXUTL 0",214,0)  S CNT=0,SD OE=+$G(SDO E)"RTN","S CDXUTL0",2 15,0) I '$ D(^SCE(SDO E,0)) G PR OCQ"RTN"," SCDXUTL0", 216,0) ;"R TN","SCDXU TL0",217,0 ) D GETPRO C(.CNT,SDO E,SCDXARRY ) G PROCQ" RTN","SCDX UTL0",218, 0) ;"RTN", "SCDXUTL0" ,219,0) ;-  Array of  procedures "RTN","SCD XUTL0",220 ,0)PROCQ S  @SCDXARRY @(0)=CNT"R TN","SCDXU TL0",221,0 ) Q"RTN"," SCDXUTL0", 222,0) ;"R TN","SCDXU TL0",223,0 ) ;"RTN"," SCDXUTL0", 224,0)GETP ROC(CNT,EN C,SCDXARRY ) ;Get pro cedures fr om Schedul ing Visits  file"RTN" ,"SCDXUTL0 ",225,0) ; "RTN","SCD XUTL0",226 ,0) N CPTS ,VCPT"RTN" ,"SCDXUTL0 ",227,0) D  GETCPT^SD OE(ENC,"CP TS")"RTN", "SCDXUTL0" ,228,0) N  CPT,QTY,I" RTN","SCDX UTL0",229, 0) S VCPT= 0"RTN","SC DXUTL0",23 0,0) F  S  VCPT=$O(CP TS(VCPT))  Q:'VCPT  D "RTN","SCD XUTL0",231 ,0) . S CP T=$G(CPTS( VCPT))"RTN ","SCDXUTL 0",232,0)  . S QTY=+$ P(CPT,U,16 )"RTN","SC DXUTL0",23 3,0) . F I =1:1:QTY S  CNT=CNT+1 ,@SCDXARRY @(CNT)=+CP T"RTN","SC DXUTL0",23 4,0) Q"RTN ","SCMSVUT 3")0^5^B22 241134"RTN ","SCMSVUT 3",1,0)SCM SVUT3   ;B P/JRP - HL 7 segment  & field va lidation u tilities ; 8/11/99 9: 54am"RTN", "SCMSVUT3" ,2,0) ;;5. 3;Scheduli ng;**142,1 80,208,239 ,395,441,5 43,631**;A UG 13, 199 3;Build 57 "RTN","SCM SVUT3",3,0 ) ;"RTN"," SCMSVUT3", 4,0) ;Stan dard input  parameter s"RTN","SC MSVUT3",5, 0) ;   DAT A  - Value  to valida te"RTN","S CMSVUT3",6 ,0) ;   DF N   - Poin t to PATIE NT file (# 2)"RTN","S CMSVUT3",7 ,0) ;   EN CDT - Date /time of e ncounter ( FileMan fo rmat)"RTN" ,"SCMSVUT3 ",8,0) ;    HLFS  - H L7 field s eparator"R TN","SCMSV UT3",9,0)  ;   HLECH  - HL7 enco ding chara cters"RTN" ,"SCMSVUT3 ",10,0) ;    HLQ   -  HL7 null d esignation "RTN","SCM SVUT3",11, 0) ;"RTN", "SCMSVUT3" ,12,0) ;St andard out put"RTN"," SCMSVUT3", 13,0) ;    1 - Valid" RTN","SCMS VUT3",14,0 ) ;   0 -  Invalid"RT N","SCMSVU T3",15,0)  ;"RTN","SC MSVUT3",16 ,0) ;"RTN" ,"SCMSVUT3 ",17,0)POW LOC(DATA,D FN) ;Priso ner of war  location" RTN","SCMS VUT3",18,0 ) ;Note: U se of DFN  is optiona l.  Use of  the DFN w ill valida te the POW "RTN","SCM SVUT3",19, 0) ;       location a nd also ve rify that  it is cons istent wit h patient' s"RTN","SC MSVUT3",20 ,0) ;       POW statu s (i.e. mu st also ha ve been a  POW).  Non -use of DF N"RTN","SC MSVUT3",21 ,0) ;       will only  validate  the POW lo cation."RT N","SCMSVU T3",22,0)  ;"RTN","SC MSVUT3",23 ,0) Q:('$D (DATA)) 0" RTN","SCMS VUT3",24,0 ) N POW,NO DE"RTN","S CMSVUT3",2 5,0) S DFN =+$G(DFN)" RTN","SCMS VUT3",26,0 ) ;Patient  a POW ?"R TN","SCMSV UT3",27,0)  S POW=1"R TN","SCMSV UT3",28,0)  I (DFN) D "RTN","SCM SVUT3",29, 0) .S NODE =$G(^DPT(D FN,.52))"R TN","SCMSV UT3",30,0)  .S POW=$T R($P(NODE, "^",5),"YN U","100")" RTN","SCMS VUT3",31,0 ) ;Invalid  location  code"RTN", "SCMSVUT3" ,32,0) I ( DATA'="")& ("456789AB "'[DATA) Q  0"RTN","S CMSVUT3",3 3,0) ;Loca tion code  not consis tent with  POW status "RTN","SCM SVUT3",34, 0) I (DATA ) Q:('POW)  0"RTN","S CMSVUT3",3 5,0) I (DA TA="") Q:( (DFN)&(POW )) 0"RTN", "SCMSVUT3" ,36,0) ;Va lid locati on code"RT N","SCMSVU T3",37,0)  Q 1"RTN"," SCMSVUT3", 38,0)RADMT HD(DATA,DF N) ;Radiat ion exposu re method" RTN","SCMS VUT3",39,0 ) ;Note: U se of DFN  is optiona l.  Use of  the DFN w ill valida te the"RTN ","SCMSVUT 3",40,0) ;       radi ation meth od and als o verify t hat it is  consistent  with"RTN" ,"SCMSVUT3 ",41,0) ;       patie nt's radia tion expos ure (i.e.  must also  have claim ed"RTN","S CMSVUT3",4 2,0) ;       exposure ).  Non-us e of DFN w ill only v alidate th e radiatio n"RTN","SC MSVUT3",43 ,0) ;       method."R TN","SCMSV UT3",44,0)  ;"RTN","S CMSVUT3",4 5,0) Q:('$ D(DATA)) 0 "RTN","SCM SVUT3",46, 0) N RAD,N ODE"RTN"," SCMSVUT3", 47,0) S DF N=+$G(DFN) "RTN","SCM SVUT3",48, 0) ;Patien t claim ex posure ?"R TN","SCMSV UT3",49,0)  S RAD=1"R TN","SCMSV UT3",50,0)  I (DFN) D "RTN","SCM SVUT3",51, 0) .S NODE =$G(^DPT(D FN,.321))" RTN","SCMS VUT3",52,0 ) .S RAD=$ TR($P(NODE ,"^",3),"Y NU","100") "RTN","SCM SVUT3",53, 0) ;Invali d method c ode"RTN"," SCMSVUT3", 54,0) I (D ATA'="") Q :((DATA'?1 N)!(DATA<2 )!(DATA>7) ) 0  ;SD*5 43 changed  >4 to >7" RTN","SCMS VUT3",55,0 ) ;Method  code not c onsistent  with expos ure status "RTN","SCM SVUT3",56, 0) I (DATA ) Q:('RAD)  0"RTN","S CMSVUT3",5 7,0) I (DA TA="") Q:( (DFN)&(RAD )) 0"RTN", "SCMSVUT3" ,58,0) ;Va lid method  code"RTN" ,"SCMSVUT3 ",59,0) Q  1"RTN","SC MSVUT3",60 ,0)NUMRANK (DATA,MINV AL,MAXVAL, DECCNT) ;N umeric ran king valid ation"RTN" ,"SCMSVUT3 ",61,0) ;I nput  : MI NVAL - Min imum value  (defaults  to no low er limit)" RTN","SCMS VUT3",62,0 ) ;          MAXVAL -  Maximum v alue (defa ults to no  upper lim it)"RTN"," SCMSVUT3", 63,0) ;          DECC NT - Decim al places  allowed (d efaults to  no limit) "RTN","SCM SVUT3",64, 0) ;Note    : DATA co nsidered i nvalid if  NULL"RTN", "SCMSVUT3" ,65,0) Q:( '$D(DATA))  0"RTN","S CMSVUT3",6 6,0) Q:(DA TA="") 0"R TN","SCMSV UT3",67,0)  Q:(DATA=" .") 0"RTN" ,"SCMSVUT3 ",68,0) N  INVALID"RT N","SCMSVU T3",69,0)  S INVALID= 0"RTN","SC MSVUT3",70 ,0) ;Gener al numeric  check"RTN ","SCMSVUT 3",71,0) Q :(DATA'?.1 "-".N.1"." .N) 0"RTN" ,"SCMSVUT3 ",72,0) ;M in value c heck"RTN", "SCMSVUT3" ,73,0) I ( $G(MINVAL) '="") D"RT N","SCMSVU T3",74,0)  .S INVALID =(DATA<MIN VAL)"RTN", "SCMSVUT3" ,75,0) Q:( INVALID) 0 "RTN","SCM SVUT3",76, 0) ;Max va lue check" RTN","SCMS VUT3",77,0 ) I ($G(MA XVAL)'="")  D"RTN","S CMSVUT3",7 8,0) .S IN VALID=(DAT A>MAXVAL)" RTN","SCMS VUT3",79,0 ) Q:(INVAL ID) 0"RTN" ,"SCMSVUT3 ",80,0) ;D ecimal che ck"RTN","S CMSVUT3",8 1,0) I ($G (DECCNT)'= "") D"RTN" ,"SCMSVUT3 ",82,0) .X  "S INVALI D=DATA'?.1 ""-"".N.1" ".""."_DEC CNT_"N""RT N","SCMSVU T3",83,0)  Q:(INVALID ) 0"RTN"," SCMSVUT3", 84,0) ;Val id"RTN","S CMSVUT3",8 5,0) Q 1"R TN","SCMSV UT3",86,0) VALFAC(DAT A) ;Determ ine if giv en facilit y number i s valid"RT N","SCMSVU T3",87,0)  Q:('$D(DAT A)) 0"RTN" ,"SCMSVUT3 ",88,0) Q: (DATA="")  0"RTN","SC MSVUT3",89 ,0) ;Inval id"RTN","S CMSVUT3",9 0,0) Q:('$ D(^DIC(4," D",DATA)))  0"RTN","S CMSVUT3",9 1,0) ;Vali d"RTN","SC MSVUT3",92 ,0) Q 1"RT N","SCMSVU T3",93,0)A CTFAC(DATA ) ;Determi ne if give n facility  number is  active"RT N","SCMSVU T3",94,0)  Q:('$D(DAT A)) 0"RTN" ,"SCMSVUT3 ",95,0) Q: (DATA="")  0"RTN","SC MSVUT3",96 ,0) N PTR4 ,ACTIVE,NO DE"RTN","S CMSVUT3",9 7,0) ;Chec k all entr ies in INS TITUTION f ile (#4) w ith given  facility n umber"RTN" ,"SCMSVUT3 ",98,0) ;  (quits whe n first ac tive entry  is found) "RTN","SCM SVUT3",99, 0) S ACTIV E=0"RTN"," SCMSVUT3", 100,0) S P TR4=0"RTN" ,"SCMSVUT3 ",101,0) F   S PTR4=+ $O(^DIC(4, "D",DATA,P TR4)) Q:(' PTR4)  D   Q:(ACTIVE) "RTN","SCM SVUT3",102 ,0) .;Get  node with  inactive f lag"RTN"," SCMSVUT3", 103,0) .S  NODE=$G(^D IC(4,PTR4, 99))"RTN", "SCMSVUT3" ,104,0) .; Inactive"R TN","SCMSV UT3",105,0 ) .Q:($P(N ODE,"^",4) ="y")"RTN" ,"SCMSVUT3 ",106,0) . ;Active"RT N","SCMSVU T3",107,0)  .S ACTIVE =1"RTN","S CMSVUT3",1 08,0) ;Don e"RTN","SC MSVUT3",10 9,0) Q ACT IVE"RTN"," SCMSVUT3", 110,0)PROV ID(DATA,HL ECH) ;Exte rnal Provi der ID"RTN ","SCMSVUT 3",111,0)  Q:('$D(DAT A)) 0"RTN" ,"SCMSVUT3 ",112,0) Q :(DATA="")  0"RTN","S CMSVUT3",1 13,0) N PR VDUZ,PRVFA C,SUBSEP,V ALID"RTN", "SCMSVUT3" ,114,0) S  SUBSEP=$E( HLECH,4)"R TN","SCMSV UT3",115,0 ) S PRVDUZ =$P(DATA,S UBSEP,1)"R TN","SCMSV UT3",116,0 ) S PRVFAC =$P(DATA,S UBSEP,2)"R TN","SCMSV UT3",117,0 ) S VALID= 0"RTN","SC MSVUT3",11 8,0) I $$N UMRANK(PRV DUZ,1,,0), $$VALFAC(P RVFAC),$$A CTFAC(PRVF AC) S VALI D=1"RTN"," SCMSVUT3", 119,0) Q V ALID"RTN", "SCMSVUT3" ,120,0)ROL EID(DATA)  ;Role Inst ance ID"RT N","SCMSVU T3",121,0)  Q:('$D(DA TA)) 0"RTN ","SCMSVUT 3",122,0)  Q:(DATA="" ) 0"RTN"," SCMSVUT3", 123,0) N R OLEID,SEQI D,VALID"RT N","SCMSVU T3",124,0)  S ROLEID= $P(DATA,"* ",1)"RTN", "SCMSVUT3" ,125,0) S  SEQID=$P(D ATA,"*",2) "RTN","SCM SVUT3",126 ,0) S VALI D=0"RTN"," SCMSVUT3", 127,0) I R OLEID'=""  I $$NUMRAN K(SEQID,1, ,0) S VALI D=1"RTN"," SCMSVUT3", 128,0) Q V ALID"RTN", "SCMSVUT3" ,129,0)VA0 1(DATA) ;V A Table 1  (Yes/No/Un known)"RTN ","SCMSVUT 3",130,0)  ;Notes: Ta ble VA01 a llows valu es of Y,N, U,1,0"RTN" ,"SCMSVUT3 ",131,0) ;      : NUL L is an ac cepted val ue"RTN","S CMSVUT3",1 32,0) Q:(' $D(DATA))  0"RTN","SC MSVUT3",13 3,0) Q:(DA TA="") 1"R TN","SCMSV UT3",134,0 ) Q:($L(DA TA)'=1) 0" RTN","SCMS VUT3",135, 0) N TMP"R TN","SCMSV UT3",136,0 ) S TMP=$T R(DATA,"YN U0","1111" )"RTN","SC MSVUT3",13 7,0) Q:(TM P'=1) 0"RT N","SCMSVU T3",138,0)  Q 1"RTN", "SCMSVUT3" ,139,0)CLA MST(VALUE, DFN) ;"RTN ","SCMSVUT 3",140,0)  ;Error cod e 9030"RTN ","SCMSVUT 3",141,0)  ;Validatin g whether  or not the  visit is  related to  MST"RTN", "SCMSVUT3" ,142,0) ;" RTN","SCMS VUT3",143, 0) ;INPUT" RTN","SCMS VUT3",144, 0) ;   ENC DT -  Date  of encoun ter"RTN"," SCMSVUT3", 145,0) ;    DFN   -   IEN pointe r from the  Outpatien t Encounte r (#409.68 ) file"RTN ","SCMSVUT 3",146,0)  ;   VALUE  -  Is enco unter rela ted (1=Yes ,0=No)"RTN ","SCMSVUT 3",147,0)  ;"RTN","SC MSVUT3",14 8,0) ;OUTP UT"RTN","S CMSVUT3",1 49,0) ;    1 = Visit  is related  to MST"RT N","SCMSVU T3",150,0)  ;   0 = V isit Not r elated to  MST"RTN"," SCMSVUT3", 151,0) ;"R TN","SCMSV UT3",152,0 ) ;"RTN"," SCMSVUT3", 153,0) N M STSTAT"RTN ","SCMSVUT 3",154,0)  I '$D(VALU E) Q 0"RTN ","SCMSVUT 3",155,0)  S MSTSTAT= $$GETSTAT^ DGMSTAPI(D FN)"RTN"," SCMSVUT3", 156,0) S M STSTAT=$P( MSTSTAT,"^ ",2)"RTN", "SCMSVUT3" ,157,0) S  MSTSTAT=$S (MSTSTAT=" Y":1,1:0)" RTN","SCMS VUT3",158, 0) Q $S(MS TSTAT=0&(V ALUE=1):0, 1:1)"RTN", "SCMSVUT3" ,159,0)MST STAT(DATA)  ;"RTN","S CMSVUT3",1 60,0) ;Err or code 70 40"RTN","S CMSVUT3",1 61,0) ;Che ck for val id MST sta tus codes  Y,N,D,U"RT N","SCMSVU T3",162,0)  ;"RTN","S CMSVUT3",1 63,0) ;INP UT"RTN","S CMSVUT3",1 64,0) ;    DATA - the  MST Statu s passed i n by routi ne SCMSVZE L "RTN","S CMSVUT3",1 65,0) ;"RT N","SCMSVU T3",166,0)  ;OUTPUT"R TN","SCMSV UT3",167,0 ) ;   1 -  Valid MST  Status"RTN ","SCMSVUT 3",168,0)  ;   0 - In valid MST  Status"RTN ","SCMSVUT 3",169,0)  ;"RTN","SC MSVUT3",17 0,0) I '$D (DATA) Q 0 "RTN","SCM SVUT3",171 ,0) I ("Y, N,U,D"[DAT A)!(DATA=" ") Q 1"RTN ","SCMSVUT 3",172,0)  Q 0"RTN"," SCMSVUT3", 173,0)MSTD ATE(DATA)  ;"RTN","SC MSVUT3",17 4,0) ;Erro r code 706 0"RTN","SC MSVUT3",17 5,0) ;Chec k for vali d date and  that MST  status is  either Y,N ,D or U"RT N","SCMSVU T3",176,0)  ; Variabl e X must b e passed t o ^%DT for  date veri fication"R TN","SCMSV UT3",177,0 ) ; Variab le Y is re turned fro m ^%DT"RTN ","SCMSVUT 3",178,0)  ;"RTN","SC MSVUT3",17 9,0) ;INPU T"RTN","SC MSVUT3",18 0,0) ;  DA TA - MST D ate Status  Changed^M ST Status  from SCMSV ZEL"RTN"," SCMSVUT3", 181,0) ;"R TN","SCMSV UT3",182,0 ) ;OUTPUT" RTN","SCMS VUT3",183, 0) ;   1 -  Valid MST  Status an d date in  a valid fo rmat"RTN", "SCMSVUT3" ,184,0) ;    0 - Inva lid MST St atus or da te in an i nvalid for mat"RTN"," SCMSVUT3", 185,0) ;"R TN","SCMSV UT3",186,0 ) N X,MSTS TAT"RTN"," SCMSVUT3", 187,0) S X =$P(DATA," ^",2)"RTN" ,"SCMSVUT3 ",188,0) S  MSTSTAT=$ P(DATA,"^" ,1)"RTN"," SCMSVUT3", 189,0) I X =""&("Y,N, D"'[MSTSTA T!(MSTSTAT ="")) Q 1" RTN","SCMS VUT3",190, 0) S X=$$F MDATE^HLFN C(X),%DT=" T""RTN","S CMSVUT3",1 91,0) D ^% DT"RTN","S CMSVUT3",1 92,0) Q $S (Y>0&("U,Y ,N,D"[MSTS TAT):1,1:0 )"RTN","SC MSVUT3",19 3,0) ;"RTN ","SCMSVUT 3",194,0)A O(DATA,DFN ) ;Validat e Agent Or ange expos . (error 7 120)"RTN", "SCMSVUT3" ,195,0) ;I NPUT  : DA TA - Value  to valida te"RTN","S CMSVUT3",1 96,0) ;          DFN  - Pointer  to PATIENT  file (#2) "RTN","SCM SVUT3",197 ,0) ;OUTPU T : 1 - Va lid claim  of exposur e to Agent  Orange"RT N","SCMSVU T3",198,0)  ;          0 - Inval id claim o f exposure  to Agent  Orange"RTN ","SCMSVUT 3",199,0)  I '$D(DATA ) Q 0"RTN" ,"SCMSVUT3 ",200,0) I  '$D(DFN)  Q 0"RTN"," SCMSVUT3", 201,0) I D ATA=1 Q 1  ;$$CANBEAO (DFN)  SD* 5.3*395 re m check fo r period o f service" RTN","SCMS VUT3",202, 0) I (DATA =0)!(DATA= "") Q 1"RT N","SCMSVU T3",203,0)  Q 0"RTN", "SCMSVUT3" ,204,0) ;" RTN","SCMS VUT3",205, 0)CL(DATA, DFN) ;Vali date Camp  Lejeune ex pos. (erro r 7390)  S D*5.3*631" RTN","SCMS VUT3",206, 0) ;INPUT   : DATA -  Value to v alidate"RT N","SCMSVU T3",207,0)  ;          DFN - Poi nter to PA TIENT file  (#2)"RTN" ,"SCMSVUT3 ",208,0) ; OUTPUT : 1  - Valid c laim of ex posure to  Camp Lejeu ne"RTN","S CMSVUT3",2 09,0) ;          0 -  Invalid cl aim of exp osure to C amp Lejeun e"RTN","SC MSVUT3",21 0,0) I '$D (DATA) Q 0 "RTN","SCM SVUT3",211 ,0) I '$D( DFN) Q 0"R TN","SCMSV UT3",212,0 ) I DATA=1  Q 1"RTN", "SCMSVUT3" ,213,0) I  (DATA=0)!( DATA="") Q  1"RTN","S CMSVUT3",2 14,0) Q 0" RTN","SCMS VUT3",215, 0) ;"RTN", "SCMSVUT3" ,216,0)CAN BEAO(DFN)  ;Check to  determine  if patient  can claim  Agent Ora nge expos. "RTN","SCM SVUT3",217 ,0) ;INPUT   : DFN -  Pointer to  PATIENT f ile (#2)"R TN","SCMSV UT3",218,0 ) ;OUTPUT  : 1 - Vali d claim of  exposure  to Agent O range"RTN" ,"SCMSVUT3 ",219,0) ;          0  - Invalid  claim of  exposure t o Agent Or ange"RTN", "SCMSVUT3" ,220,0) ;" RTN","SCMS VUT3",221, 0) N VAEL" RTN","SCMS VUT3",222, 0) I '$G(D FN) Q 0"RT N","SCMSVU T3",223,0)  I '$D(^DP T(DFN,0))  Q 0"RTN"," SCMSVUT3", 224,0) ;Ge t data nee ded to per form check "RTN","SCM SVUT3",225 ,0) D ELIG ^VADPT"RTN ","SCMSVUT 3",226,0)  ;Must be a  veteran"R TN","SCMSV UT3",227,0 ) I 'VAEL( 4) Q 0"RTN ","SCMSVUT 3",228,0)  ;Must have  POS 7"RTN ","SCMSVUT 3",229,0)  I $P($G(^D IC(21,+VAE L(2),0))," ^",3)=7 Q  1"RTN","SC MSVUT3",23 0,0) ;Can' t claim AO "RTN","SCM SVUT3",231 ,0) Q 0"RT N","SCMSVU T3",232,0) AOLOC(DATA ,DFN) ;Val idate Agen t Orange e xposure lo cation (er ror 7130)" RTN","SCMS VUT3",233, 0) ;INPUT   : DATA -  Value to v alidate"RT N","SCMSVU T3",234,0)  ;          DFN - Poi nter to PA TIENT file  (#2)"RTN" ,"SCMSVUT3 ",235,0) ; OUTPUT : 1  - Valid A gent Orang e exposure  location" RTN","SCMS VUT3",236, 0) ;          0 - Inv alid/missi ng Agent O range expo sure locat ion"RTN"," SCMSVUT3", 237,0) ;NO TES  : Pat ient's cla iming expo sure must  have an ex posure loc ation"RTN" ,"SCMSVUT3 ",238,0) N  VASV"RTN" ,"SCMSVUT3 ",239,0) I  '$G(DFN)  Q 0"RTN"," SCMSVUT3", 240,0) I ' $D(^DPT(DF N,0)) Q 0" RTN","SCMS VUT3",241, 0) I '$D(D ATA) Q 0"R TN","SCMSV UT3",242,0 ) ;Get dat a needed t o perform  check"RTN" ,"SCMSVUT3 ",243,0) D  SVC^VADPT "RTN","SCM SVUT3",244 ,0) ;No cl aim - shou ldn't have  a locatio n"RTN","SC MSVUT3",24 5,0) I 'VA SV(2) Q $S (DATA="":1 ,1:0)"RTN" ,"SCMSVUT3 ",246,0) ; Claims exp osure - mu st have a  valid loca tion"RTN", "SCMSVUT3" ,247,0) Q  $S(DATA="" :0,"VKO"[D ATA:1,1:0) "RTN","SCM SVZEL")0^6 ^B9007520" RTN","SCMS VZEL",1,0) SCMSVZEL    ;ALB/ESD  HL7 ZEL Se gment Vali dation ; 6 /20/05 9:2 4am"RTN"," SCMSVZEL", 2,0) ;;5.3 ;Schedulin g;**44,66, 142,184,18 0,222,239, 325,441,63 1**;Aug 13 , 1993;Bui ld 57"RTN" ,"SCMSVZEL ",3,0) ;"R TN","SCMSV ZEL",4,0)  ;"RTN","SC MSVZEL",5, 0)EN(ZELSE G,HLQ,HLFS ,VALERR,DF N) ;"RTN", "SCMSVZEL" ,6,0) ; En try point  to return  the HL7 ZE L (Patient  Eligibili ty) valida tion segme nt"RTN","S CMSVZEL",7 ,0) ;"RTN" ,"SCMSVZEL ",8,0) ;   Input: .ZE LSEG - ZEL  Segment A rray"RTN", "SCMSVZEL" ,9,0) ;               HLQ - HL7  null varia ble"RTN"," SCMSVZEL", 10,0) ;             H LFS - HL7  field sepa rator"RTN" ,"SCMSVZEL ",11,0) ;           V ALERR - Th e array na me to put  the errors  in"RTN"," SCMSVZEL", 12,0) ;               DFN - The  DFN of the  patient"R TN","SCMSV ZEL",13,0)  ;"RTN","S CMSVZEL",1 4,0) ; Out put:  1 if  ZEL passe d validity  check"RTN ","SCMSVZE L",15,0) ;            Error mess age if ZEL  failed va lidity che ck in form  of:"RTN", "SCMSVZEL" ,16,0) ;           -1 ^"xxx fail ed validit y check" ( xxx=elemen t in ZEL s egment)"RT N","SCMSVZ EL",17,0)  ;"RTN","SC MSVZEL",18 ,0) ;"RTN" ,"SCMSVZEL ",19,0) N  I,MSG,X,CN T,DATA,SEG ,ELIG,VET, LP,MSTSTAT ,MSTDATE,S EGLINE,NOD E,OFFSET"R TN","SCMSV ZEL",20,0)  N CVET"RT N","SCMSVZ EL",21,0)  S SEG="ZEL ",CNT=1"RT N","SCMSVZ EL",22,0)  S MSG="-1^ Element in  ZEL segme nt failed  validity c heck""RTN" ,"SCMSVZEL ",23,0) S  ZELSEG(1)= $G(ZELSEG( 1))"RTN"," SCMSVZEL", 24,0) D VA LIDATE^SCM SVUT0(SEG, ZELSEG(1), "0010",VAL ERR,.CNT)" RTN","SCMS VZEL",25,0 ) I $D(@VA LERR@(SEG) ) G ENQ"RT N","SCMSVZ EL",26,0)  ;"RTN","SC MSVZEL",27 ,0) ;- Con vert HLQ t o null"RTN ","SCMSVZE L",28,0) S  ZELSEG(1) =$$CONVERT ^SCMSVUT0( ZELSEG(1), HLFS,HLQ)" RTN","SCMS VZEL",29,0 ) S I=0"RT N","SCMSVZ EL",30,0)  F  S I=+$O (ZELSEG(1, I)) Q:'I   S ZELSEG(1 ,I)=$$CONV ERT^SCMSVU T0(ZELSEG( 1,I),HLFS, HLQ)"RTN", "SCMSVZEL" ,31,0) ;"R TN","SCMSV ZEL",32,0)  S OFFSET= 0,NODE=0,S EGLINE=ZEL SEG(1)"RTN ","SCMSVZE L",33,0) ;  added 42  (starts at  1 so real ly this is  piece 41)  for Camp  Lejeune SD *5.3*631 J LS"RTN","S CMSVZEL",3 4,0) F I=1 ,3,9,19,20 ,23,24,25, 30,38,39,4 1,42 DO"RT N","SCMSVZ EL",35,0)  . I $L(SEG LINE,HLFS) <(I-OFFSET ) D"RTN"," SCMSVZEL", 36,0) . .  ;Segment w rapped"RTN ","SCMSVZE L",37,0) .  . S OFFSE T=OFFSET+$ L(SEGLINE, HLFS)-1"RT N","SCMSVZ EL",38,0)  . . S NODE =+$O(ZELSE G(1,NODE)) "RTN","SCM SVZEL",39, 0) . . I N ODE=0 S SE GLINE="",N ODE=+$O(ZE LSEG(1,NOD E),-1) Q"R TN","SCMSV ZEL",40,0)  . . S SEG LINE=$G(ZE LSEG(1,NOD E))"RTN"," SCMSVZEL", 41,0) . S  DATA=$P(SE GLINE,HLFS ,I-OFFSET) "RTN","SCM SVZEL",42, 0) . I I=3  S ELIG=DA TA"RTN","S CMSVZEL",4 3,0) . I I =9 S VET=D ATA"RTN"," SCMSVZEL", 44,0) . I  I=24 S MST STAT=DATA" RTN","SCMS VZEL",45,0 ) . I I=25  S MSTDATE =DATA,DATA =MSTSTAT_" ^"_MSTDATE "RTN","SCM SVZEL",46, 0) . I I=3 8 S CVET=D ATA"RTN"," SCMSVZEL", 47,0) . I  I=39 S DAT A=CVET_"^" _DATA"RTN" ,"SCMSVZEL ",48,0) .  D VALIDATE ^SCMSVUT0( SEG,DATA,$ P($T(@(I)) ,";",3),VA LERR,.CNT) "RTN","SCM SVZEL",49, 0) . Q"RTN ","SCMSVZE L",50,0) ; "RTN","SCM SVZEL",51, 0) S DATA= ELIG_"^"_V ET"RTN","S CMSVZEL",5 2,0) F LP= 32,91 D VA LIDATE^SCM SVUT0(SEG, $S(LP=32:E LIG,LP=91: VET,1:DATA ),$P($T(@( LP)),";",3 ),VALERR,. CNT)"RTN", "SCMSVZEL" ,53,0) ;"R TN","SCMSV ZEL",54,0) ENQ Q $S($ D(@VALERR@ (SEG)):MSG ,1:1)"RTN" ,"SCMSVZEL ",55,0) ;" RTN","SCMS VZEL",56,0 ) ;"RTN"," SCMSVZEL", 57,0) ;"RT N","SCMSVZ EL",58,0)E RR ;;Inval id or miss ing patien t eligibil ity data f or encount er (HL7 ZE L segment) "RTN","SCM SVZEL",59, 0) ;"RTN", "SCMSVZEL" ,60,0) ;"R TN","SCMSV ZEL",61,0)  ;- ZEL da ta element s validate d"RTN","SC MSVZEL",62 ,0) ;"RTN" ,"SCMSVZEL ",63,0)1 ; ;0035;HL7  SEGMENT NA ME"RTN","S CMSVZEL",6 4,0)3 ;;70 00;ELIGIBI LITY CODE  MISSING"RT N","SCMSVZ EL",65,0)3 1 ;;7020;E LIGIBILITY  CODE INCO NSISTENT W ITH VET ST ATUS"RTN", "SCMSVZEL" ,66,0)32 ; ;7030;ELIG IBILITY CO DE INACTIV E"RTN","SC MSVZEL",67 ,0)9 ;;705 0;VETERAN? "RTN","SCM SVZEL",68, 0)91 ;;710 0;VET STAT US INCONSI STENT WITH  POW"RTN", "SCMSVZEL" ,69,0)19 ; ;7120;AGEN T ORANGE E XPOSURE"RT N","SCMSVZ EL",70,0)2 3 ;;7150;I NVALID/INC ONSISTENT  RADIATION  EXPOSURE M ETHOD"RTN" ,"SCMSVZEL ",71,0)20  ;;7210;RAD IATION EXP OSURE INDI CATED"RTN" ,"SCMSVZEL ",72,0)24  ;;7040;INV ALID MST C LASSIFICAT ION"RTN"," SCMSVZEL", 73,0)25 ;; 7060;MST S TATUS DATE  INVALID O R INCONSIS TENT WITH  MST STATUS "RTN","SCM SVZEL",74, 0)30 ;;713 0;AGENT OR ANGE EXPOS URE LOCATI ON"RTN","S CMSVZEL",7 5,0)38 ;;7 330;COMBAT  VET INDIC ATOR"RTN", "SCMSVZEL" ,76,0)39 ; ;7340;COMB AT VET END  DATE"RTN" ,"SCMSVZEL ",77,0)41  ;;7370;PRO J 112/SHAD  INDICATOR "RTN","SCM SVZEL",78, 0)42 ;;739 0;CAMP LEJ EUNE INDIC ATOR"RTN", "SCRPW23") 0^10^B5669 8845"RTN", "SCRPW23", 1,0)SCRPW2 3 ;RENO/KE ITH - ACRP  Ad Hoc Re port (cont .) ;15 Jul  98  02:38 PM"RTN","S CRPW23",2, 0) ;;5.3;S cheduling; **144,474, 593,631**; AUG 13, 19 93;Build 5 7"RTN","SC RPW23",3,0 )DIRB(SDFL ) ;Get def ault value s for rang e"RTN","SC RPW23",4,0 ) ;Require d input: S DFL="F" fo r first, " L" for las t"RTN","SC RPW23",5,0 ) N SDX S  SDX=$O(SDP AR("X",SDS 2,$S(SDDV: 5,1:4),"") ,$S(SDFL=" F":1,1:-1) ) Q $S(SDX =""!'SDDV: SDX,1:SDPA R("X",SDS2 ,5,SDX))"R TN","SCRPW 23",6,0) ; "RTN","SCR PW23",7,0) RL ;Prompt  for range  or list"R TN","SCRPW 23",8,0) N  SDI,SDIRQ ,SDCSYS X: $L($P(SDAC T,T,9)) $P (SDACT,T,9 ) S SDDV=0  S:$P(SDAC T,T,2)="D"  SDDV=1,SD PAR("X",SD S2,6)="D"" RTN","SCRP W23",9,0)  I $P(SDPAR ("X",SDS2, 2),U)="N"  D NULL Q"R TN","SCRPW 23",10,0)  I ($P(SDAC T,T,2)="P" ),($P(SDAC T,T,3)="^I CD9(") S S DCSYS=$$IC DSYS()"RTN ","SCRPW23 ",11,0) I  $P(SDPAR(" X",SDS2,2) ,U)="L" D  LST Q"RTN" ,"SCRPW23" ,12,0)RNG  N SDR1,SDR 2 D SUBT^S CRPW50("** * Item Ran ge Selecti on ***")"R TN","SCRPW 23",13,0)R 1 W !!,"St art with:"  S SDR1=$$ SEL($P(SDA CT,T,2),$$ DIRB("F"))  Q:SDOUT!S DNUL"RTN", "SCRPW23", 14,0) S SD R2=$O(SDPA R("X",SDS2 ,$S(SDDV:5 ,1:4),""), -1) I $L(S DR2),$P(SD R1,U,$S(SD DV:1,1:2)) ]SDR2 F SD I=SDS1,"X"  K SDPAR(S DI,SDS2,$S (SDDV:5,1: 4),SDR2)"R TN","SCRPW 23",15,0)R 2 W !!,"En d with:" S  SDR2=$$SE L($P(SDACT ,T,2),$$DI RB("L")) Q :SDOUT!SDN UL"RTN","S CRPW23",16 ,0) I '$$R COL() W !! ,$C(7),"En d value mu st collate  after sta rt value!"  G R2"RTN" ,"SCRPW23" ,17,0) F S DX="SDR1", "SDR2" S S DPAR("X",S DS2,4,$P(@ SDX,U,2),$ P(@SDX,U)) ="""RTN"," SCRPW23",1 8,0) F SDX ="SDR1","S DR2" S SDP AR("X",SDS 2,5,$P(@SD X,U))=$P(@ SDX,U,2)"R TN","SCRPW 23",19,0)  Q"RTN","SC RPW23",20, 0) ;"RTN", "SCRPW23", 21,0)ICDSY S() ;Promp t for codi ng system.   (Structu rally simi lar to $$R L^SCRPW22. )"RTN","SC RPW23",22, 0) N IEN,C SYS,I10DTI ,I10DTE"RT N","SCRPW2 3",23,0) I  $D(SDPAR( "X",SDS2,4 )) D  I 1" RTN","SCRP W23",24,0)  . S IEN=$ O(SDPAR("X ",SDS2,5," ")) Q:IEN= """RTN","S CRPW23",25 ,0) . S CS YS=$$CSI^S CRPWICD(80 ,IEN)"RTN" ,"SCRPW23" ,26,0) E   I SDS1="P"  D  I 1"RT N","SCRPW2 3",27,0) .  S Y=$$IMP ^SCRPWICD( 30) S I10D TI=Y X ^DD ("DD") S I 10DTE=Y"RT N","SCRPW2 3",28,0) .  K DIR S D IR(0)="S^9 :ICD-9  (P RIOR TO "_ I10DTE_"); 10:ICD-10  ("_I10DTE_ " AND AFTE R)""RTN"," SCRPW23",2 9,0) . S D IR("A")="S elect codi ng system"  S DIR("B" )=$S(DT'<I 10DTI:"10" ,1:"9")"RT N","SCRPW2 3",30,0) .  D ^DIR K  DIR S CSYS =$S($P(Y,U ,1)="9":1, $P(Y,U,1)= "10":30,1: $S(DT<I10D TI:1,1:30) )"RTN","SC RPW23",31, 0) E  I SD S1="L" D   I 1"RTN"," SCRPW23",3 2,0) . S C SYS=$S($P( SDPAR("L", 1),U,1)<$$ IMP^SCRPWI CD(30):1,1 :30)"RTN", "SCRPW23", 33,0) Q CS YS"RTN","S CRPW23",34 ,0) ;"RTN" ,"SCRPW23" ,35,0)RCOL () ;Determ ine range  collation  validity"R TN","SCRPW 23",36,0)  ;Output: 1 =valid, 0= invalid"RT N","SCRPW2 3",37,0) I  $P(SDR1,U ,2)=+$P(SD R1,U,2),$P (SDR2,U,2) =+$P(SDR2, U,2) Q SDR 1'>SDR2"RT N","SCRPW2 3",38,0) I  SDDV Q $P (SDR1,U)'> $P(SDR2,U) "RTN","SCR PW23",39,0 ) Q $P(SDR 1,U,2)']$P (SDR2,U,2) "RTN","SCR PW23",40,0 ) ;"RTN"," SCRPW23",4 1,0)NULL ; Set list f or null va lue"RTN"," SCRPW23",4 2,0) S SDP AR("X",SDS 2,4,"~~~NO NE~~~","~~ ~NONE~~~") ="",SDPAR( "X",SDS2,5 ,"~~~NONE~ ~~")="~~~N ONE~~~" Q" RTN","SCRP W23",43,0)  ;"RTN","S CRPW23",44 ,0)LST I $ D(SDPAR("X ",SDS2,4))  D LST1"RT N","SCRPW2 3",45,0) D  SUBT^SCRP W50("*** I tem List S election * **") W !"R TN","SCRPW 23",46,0)  F I=1:1:$P (SDACT,T,6 ) S SDX=$$ SEL($P(SDA CT,T,2)) Q :SDOUT!SDN UL  D LST0 "RTN","SCR PW23",47,0 ) Q"RTN"," SCRPW23",4 8,0) ;"RTN ","SCRPW23 ",49,0)LST 0 I $D(SDP AR("X",SDS 2,5,$P(SDX ,U))) Q:$$ LSD()"RTN" ,"SCRPW23" ,50,0) S S DPAR("X",S DS2,4,$P(S DX,U,2),$P (SDX,U))=" ""RTN","SC RPW23",51, 0) S SDPAR ("X",SDS2, 5,$P(SDX,U ))=$P(SDX, U,2)"RTN", "SCRPW23", 52,0) Q"RT N","SCRPW2 3",53,0) ; "RTN","SCR PW23",54,0 )LSD() N D IR W !!,$C (7),$P(SDX ,U,2)," is  already s elected."  S DIR(0)=" Y",DIR("A" )="Do you  want to de lete it",D IR("B")="N O" D ^DIR  I $D(DTOUT )!$D(DUOUT ) S SDOUT= 1 Q 0"RTN" ,"SCRPW23" ,55,0) I Y  D  W !,"    ...delet ed." Q 1"R TN","SCRPW 23",56,0)  .F SDI=SDS 1,"X" K SD PAR(SDI,SD S2,5,$P(SD X,U)),SDPA R(SDI,SDS2 ,4,$P(SDX, U,2),$P(SD X,U))"RTN" ,"SCRPW23" ,57,0) .Q" RTN","SCRP W23",58,0)  Q 0"RTN", "SCRPW23", 59,0) ;"RT N","SCRPW2 3",60,0)LS T1 ;List e xisting it em selecti ons"RTN"," SCRPW23",6 1,0) N SDO UT,SDL,SDX  S SDOUT=0 ,SDL=1,SDX ="" W !,"I tems curre ntly selec ted:""RTN" ,"SCRPW23" ,62,0) F   S SDX=$O(S DPAR("X",S DS2,4,SDX) ) Q:SDX="" !SDOUT  S  SDL=SDL+1  W !?5,SDX  D:SDL>15 W AIT^SCRPW2 2"RTN","SC RPW23",63, 0) Q"RTN", "SCRPW23", 64,0) ;"RT N","SCRPW2 3",65,0)SE L(SDTYP,SD IRB) ;Sele ct items f or list or  range"RTN ","SCRPW23 ",66,0) ;R equired in put: SDTYP =type of d ata (D, P,  F, N, T,  C, PP, S)" RTN","SCRP W23",67,0)  ;Optional  input: SD IRB=value  for defaul t prompt"R TN","SCRPW 23",68,0)  N SDX S SD X="" D @SD TYP Q SDX" RTN","SCRP W23",69,0)  ;"RTN","S CRPW23",70 ,0)D ;Get  date value s"RTN","SC RPW23",71, 0) N DIR M  DIR=SDIRQ  S DIR(0)= $P(SDACT,T ,4),DIR("A ")="Select  "_$P(SDAC T,T) S:$L( $G(SDIRB))  DIR("B")= SDIRB D ^D IR I $D(DT OUT)!$D(DU OUT) S SDO UT=1 Q"RTN ","SCRPW23 ",72,0) I  '$L(Y) S S DNUL=1 Q"R TN","SCRPW 23",73,0)  S SDX=Y X  ^DD("DD")  S SDX=SDX_ U_Y X:$L($ P(SDACT,T, 8)) $P(SDA CT,T,8) Q" RTN","SCRP W23",74,0)  ;"RTN","S CRPW23",75 ,0)P ;Get  pointer va lues ;SD*5 .3*474 add ed PSCRN t o screen c ertain sta tus types" RTN","SCRP W23",76,0)  N DIC M D IC=SDIRQ S  DIC=$P(SD ACT,T,3),D IC(0)="AEM Q",DIC("S" )=$P(SDACT ,T,4) K:'$ L(DIC("S") ) DIC("S")  D PSCRN D  ^DIC I $D (DTOUT)!$D (DUOUT) S  SDOUT=1 Q" RTN","SCRP W23",77,0)  I Y'>0 S  SDNUL=1 Q" RTN","SCRP W23",78,0)  S SDX=Y X :$L($P(SDA CT,T,8)) $ P(SDACT,T, 8) Q"RTN", "SCRPW23", 79,0) ;"RT N","SCRPW2 3",80,0)PS CRN ;scree n out the  4 cancella tion type  status' SD *5.3*474"R TN","SCRPW 23",81,0)  I DIC="^SD (409.63,"  S DIC("S") ="I $P(^(0 ),U,2)'="" C"",$P(^(0 ),U,2)'="" CA"",$P(^( 0),U,2)'=" "PC"",$P(^ (0),U,2)'= ""PCA""""R TN","SCRPW 23",82,0)  I DIC="^IC D9(" S DIC ("S")="I $ $CSI^SCRPW ICD(80,Y)= "_SDCSYS"R TN","SCRPW 23",83,0)  Q"RTN","SC RPW23",84, 0) ;"RTN", "SCRPW23", 85,0)F ;Ge t field va lues"RTN", "SCRPW23", 86,0) N DI R M DIR=SD IRQ S DIR( 0)=$P(SDAC T,T,3) S:$ L($G(SDIRB )) DIR("B" )=SDIRB D  ^DIR I $D( DTOUT)!$D( DUOUT) S S DOUT=1 Q"R TN","SCRPW 23",87,0)  I '$D(DIR( "B")),X=""  S SDNUL=1  Q"RTN","S CRPW23",88 ,0) S SDX= Y_U_$G(Y(0 )) X:$L($P (SDACT,T,8 )) $P(SDAC T,T,8) Q"R TN","SCRPW 23",89,0)  ;"RTN","SC RPW23",90, 0)N ;Get n umber valu e"RTN","SC RPW23",91, 0) N DIR M  DIR=SDIRQ  S DIR(0)= $P(SDACT,T ,4),DIR("A ")="Select  "_$P(SDAC T,T) S:$L( $G(SDIRB))  DIR("B")= SDIRB D ^D IR I $D(DT OUT)!$D(DU OUT) S SDO UT=1 Q"RTN ","SCRPW23 ",92,0) I  Y'?1.N S S DNUL=1 Q"R TN","SCRPW 23",93,0)  S SDX=Y_U_ Y X:$L($P( SDACT,T,8) ) $P(SDACT ,T,8) Q"RT N","SCRPW2 3",94,0) ; "RTN","SCR PW23",95,0 )T ;Get te xt value"R TN","SCRPW 23",96,0)  N DIR M DI R=SDIRQ S  DIR(0)=$P( SDACT,T,4) ,DIR("A")= "Select "_ $P(SDACT,T ) S:$L($G( SDIRB)) DI R("B")=SDI RB D ^DIR  I $D(DTOUT )!$D(DUOUT ) S SDOUT= 1 Q"RTN"," SCRPW23",9 7,0) I '$L (Y) S SDNU L=1 Q"RTN" ,"SCRPW23" ,98,0) S S DX=Y_U_Y X :$L($P(SDA CT,T,8)) $ P(SDACT,T, 8) Q"RTN", "SCRPW23", 99,0) ;"RT N","SCRPW2 3",100,0)C  ;Get comp uted value "RTN","SCR PW23",101, 0) D @($P( SDACT,T,4) ) X:$L($P( SDACT,T,8) ) $P(SDACT ,T,8) Q"RT N","SCRPW2 3",102,0)  ;"RTN","SC RPW23",103 ,0)PP ;Get  pointer v alue from  file multi ple"RTN"," SCRPW23",1 04,0) N DI C M DIC=SD IRQ S DIC= $P($P(SDAC T,T,3),";" ),DIC(0)=" AEMQ",DIC( "B")=$P($G (SDIRB),"; ") K:'$L(D IC("B")) D IC("B") D  ^DIC I $D( DTOUT)!$D( DUOUT) S S DOUT=1 Q"R TN","SCRPW 23",105,0)  I Y<1 S S DNUL=1 Q"R TN","SCRPW 23",106,0)  S SDX=Y,D IC=DIC_+SD X_$P($P(SD ACT,T,3)," ;",2),DIC( "B")=$P($G (SDIRB),"; ",2) K:'$L (DIC("B"))  DIC("B")  D ^DIC I $ D(DTOUT)!$ D(DUOUT) S  SDX="",SD OUT=1 Q"RT N","SCRPW2 3",107,0)  I Y<1 S SD X="",SDNUL =1 Q"RTN", "SCRPW23", 108,0) S S DX=+SDX_"; "_+Y_U_$P( SDX,U,2)_"  / "_$P(Y, U,2) X:$L( $P(SDACT,T ,8)) $P(SD ACT,T,8) Q "RTN","SCR PW23",109, 0) ;"RTN", "SCRPW23", 110,0)S ;G et set-of- codes valu e"RTN","SC RPW23",111 ,0) N DIR  M DIR=SDIR Q X $P(SDA CT,T,3) S  DIR("A")=" Select "_$ P(SDACT,T)  S:$L($G(S DIRB)) DIR ("B")=SDIR B D ^DIR I  $D(DTOUT) !$D(DUOUT)  S SDOUT=1  Q"RTN","S CRPW23",11 2,0) I '$L (Y) S SDNU L=1 Q"RTN" ,"SCRPW23" ,113,0) S  SDX=Y_U_Y( 0) X:$L($P (SDACT,T,8 )) $P(SDAC T,T,8) Q"R TN","SCRPW 23",114,0)  ;"RTN","S CRPW23",11 5,0)VCP(SD X) ;Valida te Stop Co de credit  pair"RTN", "SCRPW23", 116,0) ;Re quired inp ut: SDX=6  digit nume ric value" RTN","SCRP W23",117,0 ) ;Output:  1=valid c redit pair , 0=invali d credit p air"RTN"," SCRPW23",1 18,0) G:SD X'?6N VCPQ  G:'$D(^DI C(40.7,"C" ,$E(SDX,1, 3))) VCPQ  G:'$D(^DIC (40.7,"C", $E(SDX,4,6 )))&($E(SD X,4,6)'="0 00") VCPQ" RTN","SCRP W23",119,0 ) Q 1"RTN" ,"SCRPW23" ,120,0) ;" RTN","SCRP W23",121,0 )VCPQ W $C (7),"   ?? ",!,"This  response m ust be a 6  digit num eric value ",!,"that  represents  two valid  stop code s!" Q 0"RT N","SCRPW2 3",122,0)  ;"RTN","SC RPW23",123 ,0)PLIST ; Print cate gory list" RTN","SCRP W23",124,0 ) N ZTSAVE  D EN^XUTM DEVQ("PLST ^SCRPW23", "CATEGORY  LIST",.ZTS AVE) Q"RTN ","SCRPW23 ",125,0)PL ST ;Print  category l ist"RTN"," SCRPW23",1 26,0) D:'$ D(^TMP("SC RPW",$J,"S EL")) BLD^ SCRPW21"RT N","SCRPW2 3",127,0)  S I=0 F  S  I=$O(^TMP ("SCRPW",$ J,"SEL",1, I)) Q:'I   S X1=$O(^T MP("SCRPW" ,$J,"SEL", 1,I,"")) W  !!,$P(^TM P("SCRPW", $J,"SEL",1 ,I,X1),"~" ) D PLST1" RTN","SCRP W23",128,0 ) K I,II,X 1,X2,^TMP( "SCRPW",$J ) Q"RTN"," SCRPW23",1 29,0) ;"RT N","SCRPW2 3",130,0)P LST1 S II= 0 F  S II= $O(^TMP("S CRPW",$J," SEL",2,X1, II)) Q:'II   S X2=$O( ^TMP("SCRP W",$J,"SEL ",2,X1,II, "")) W !?4 ,$P(^TMP(" SCRPW",$J, "SEL",2,X1 ,II,X2),"~ ")"RTN","S CRPW23",13 1,0) Q"RTN ","SCRPW23 ",132,0) ; "RTN","SCR PW23",133, 0)DISP0 ;R eturn to f ull screen  scrolling "RTN","SCR PW23",134, 0) Q:$E(IO ST)'="C""R TN","SCRPW 23",135,0)  D ENS^%ZI SS S SDRM= ^%ZOSF("RM "),SDXY=^% ZOSF("XY") ,(IOTM,IOB M)=0 W $$X Y(IOSTBM,1 ),@IOF N D X,DY,X S ( DX,DY)=0 X  SDXY S X= IOM X SDRM  Q"RTN","S CRPW23",13 6,0) ;"RTN ","SCRPW23 ",137,0)DI SP(SDTOP,S DBOT) ;Cre ate center ed scrolli ng region" RTN","SCRP W23",138,0 ) ;Require d input: S DTOP=text  to center  at top of  screen"RTN ","SCRPW23 ",139,0) ; Required i nput: SDBO T(n)=numbe red array  of text to  display a t bottom o f screen"R TN","SCRPW 23",140,0)  N X D DIS P0 S X=0 X  SDRM W $$ XY(IORVON)  F I=1:1:( 78-$L(SDTO P)\2) W "- ""RTN","SC RPW23",141 ,0) W " ", SDTOP," "  F  W "-" Q :$X>79"RTN ","SCRPW23 ",142,0) W  $$XY(IORV OFF) S IOT M=3 W $$XY (IOSTBM,1)  S (C,I)=" " F  S I=$ O(SDBOT(I) ) Q:I=""   S C=C+1"RT N","SCRPW2 3",143,0)  F  W ! Q:$ Y>(IOSL-C) "RTN","SCR PW23",144, 0) S II=$O (SDBOT("") ) Q:II=""   W $$XY(IO RVON) F I= 1:1:(78-$L (SDBOT(II) )\2) W "-" "RTN","SCR PW23",145, 0) W " ",S DBOT(II),"  " F  W "- " Q:$X>79" RTN","SCRP W23",146,0 ) W $$XY(I ORVOFF) F   S II=$O(S DBOT(II))  Q:II=""  W  !,$E(SDBO T(II),1,80 )"RTN","SC RPW23",147 ,0) S IOBM =(IOSL-C-1 ) W $$XY(I OSTBM,1) Q "RTN","SCR PW23",148, 0) ;"RTN", "SCRPW23", 149,0)XY(X ,SDI) ;Mai ntain $X,  $Y"RTN","S CRPW23",15 0,0) ;Requ ired input : X=screen  handling  variable t o write"RT N","SCRPW2 3",151,0)  ;Optional  input: SDI =1 (to spe cify the u se of indi rection)"R TN","SCRPW 23",152,0)  N DX,DY S  DX=$X,DY= $Y"RTN","S CRPW23",15 3,0) I $G( SDI) W @X  X SDXY Q " ""RTN","SC RPW23",154 ,0) W X X  SDXY Q """ RTN","SCRP W23",155,0 ) ;"RTN"," SCRPW23",1 56,0)DIR(D IR,SDLEV,S DEXE,SDS,S DO,SDPFL,S DA) ;Ask q uestions!" RTN","SCRP W23",157,0 ) ;Require d input: D IR array ( pass by re ference)"R TN","SCRPW 23",158,0)  ;Required  input: SD LEV=level  to build D IR(0) for  large sets "RTN","SCR PW23",159, 0) ;Option al input:  SDEXE=code  to execut e prior to  ^DIR"RTN" ,"SCRPW23" ,160,0) ;O ptional in put: SDS=s ubscript l ookup valu e for leve l 2 (requi red for le vel 2)"RTN ","SCRPW23 ",161,0) ; Optional i nput: SDO= "O" to ind icate inpu t is optio nal"RTN"," SCRPW23",1 62,0) ;Opt ional inpu t: SDPFL=p rint field  level (1, 2) for pri nt field p rompts"RTN ","SCRPW23 ",163,0) ; Optional i nput: SDA= 1 to force  single it em selecti on prompt" RTN","SCRP W23",164,0 ) X:$L($G( SDEXE)) SD EXE I '$D( DIR(0)) D  @("DIR"_SD LEV)"RTN", "SCRPW23", 165,0) I ' $G(SDA),$E (DIR(0))=" S",$L(DIR( 0),":")=2  Q $P($P(DI R(0),U,2), ":")_U_$P( DIR(0),":" ,2)"RTN"," SCRPW23",1 66,0) D ^D IR I $D(DT OUT)!$D(DU OUT) S SDO UT=1 Q """ RTN","SCRP W23",167,0 ) I X="" S  SDNUL=1 Q  """RTN"," SCRPW23",1 68,0) Q Y_ U_$S($L($G (Y(0))):Y( 0),1:Y)"RT N","SCRPW2 3",169,0)  ;"RTN","SC RPW23",170 ,0)DIR1 N  X,I,II S X ="",I=0 F   S I=$O(^T MP("SCRPW" ,$J,"SEL", 1,I)) Q:'I   S II=""  F  S II=$O (^TMP("SCR PW",$J,"SE L",1,I,II) ) Q:II=""   S:$$PFL1( ) X=X_";"_ II_":"_$P( ^TMP("SCRP W",$J,"SEL ",1,I,II), T)"RTN","S CRPW23",17 1,0) ;S DI R(0)="S"_$ G(SDO)_"^" _$E(X,2,24 5) Q     ;  SD*5.3*63 1"RTN","SC RPW23",172 ,0) S DIR( 0)="S"_$G( SDO)_"^"_$ E(X,2,$L(X )) Q"RTN", "SCRPW23", 173,0) ;"R TN","SCRPW 23",174,0) DIR2 N X,I ,II S X="" ,I=0 F  S  I=$O(^TMP( "SCRPW",$J ,"SEL",2,S DS,I)) Q:' I  S II=""  F  S II=$ O(^TMP("SC RPW",$J,"S EL",2,SDS, I,II)) Q:I I=""  S:$$ PFL2() X=X _";"_II_": "_$P(^TMP( "SCRPW",$J ,"SEL",2,S DS,I,II),T )"RTN","SC RPW23",175 ,0) ;S DIR (0)="S"_$G (SDO)_"^"_ $E(X,2,245 ) Q     ;  SD*5.3*631 "RTN","SCR PW23",176, 0) S DIR(0 )="S"_$G(S DO)_"^"_$E (X,2,$L(X) ) Q"RTN"," SCRPW23",1 77,0) ;"RT N","SCRPW2 3",178,0)P FL1() ;Pri nt field l evel 1 eva luator"RTN ","SCRPW23 ",179,0) Q :'$G(SDPFL ) 1"RTN"," SCRPW23",1 80,0) Q $P (^TMP("SCR PW",$J,"SE L",1,I,II) ,T,2)>(SDP FL-1)"RTN" ,"SCRPW23" ,181,0) ;" RTN","SCRP W23",182,0 )PFL2() ;P rint field  level 2 e valuator"R TN","SCRPW 23",183,0)  Q:'$G(SDP FL) 1"RTN" ,"SCRPW23" ,184,0) Q  $P(^TMP("S CRPW",$J," SEL",2,SDS ,I,II),T,2 )>(SDPFL-1 )"RTN","SC RPW23",185 ,0) ;"RTN" ,"SCRPW23" ,186,0)DIR B1(S1,S2,S DEF) ;Set  DIR("B")"R TN","SCRPW 23",187,0)  ;Required  input: S1 , S2=subsc ript value s"RTN","SC RPW23",188 ,0) ;Optio nal input:  SDEF=defa ult value" RTN","SCRP W23",189,0 ) S DIR("B ")=$S($D(S DPAR(S1,S2 )):$P(SDPA R(S1,S2),U ,2),1:$G(S DEF))"RTN" ,"SCRPW23" ,190,0) K: '$L(DIR("B ")) DIR("B ") Q"RTN", "SCRPW24") 0^11^B8031 5888"RTN", "SCRPW24", 1,0)SCRPW2 4 ;RENO/KE ITH - ACRP  Ad Hoc Re port (cont .) ;06/19/ 99"RTN","S CRPW24",2, 0) ;;5.3;S cheduling; **144,163, 180,254,24 3,295,329, 351,510,53 0,562,576, 593,631**; AUG 13, 19 93;Build 5 7"RTN","SC RPW24",3,0 ) ;06/19/9 9 ACS - Ad ded CPT mo difier API  calls"RTN ","SCRPW24 ",4,0) ;11 /26/03 RLC  - 329 fix es primary /secondary  dx proble m with rep ort"RTN"," SCRPW24",5 ,0) ;"RTN" ,"SCRPW24" ,6,0)APAC( SDX) ;Get  all proced ure codes" RTN","SCRP W24",7,0)  D APAC^SCR PW241(.SDX )"RTN","SC RPW24",8,0 ) D NX Q"R TN","SCRPW 24",9,0) ; "RTN","SCR PW24",10,0 )APOTR ;Tr ansform pr ocedure ex ternal val ue"RTN","S CRPW24",11 ,0) D APOT R^SCRPW241 (.SDX)"RTN ","SCRPW24 ",12,0) Q" RTN","SCRP W24",13,0)  ;"RTN","S CRPW24",14 ,0)APAP(SD X) ;Get am bulatory p rocedures  (no E&M co des)"RTN", "SCRPW24", 15,0) D AP AP^SCRPW24 1(.SDX)"RT N","SCRPW2 4",16,0) D  NX Q"RTN" ,"SCRPW24" ,17,0) ;"R TN","SCRPW 24",18,0)A PEM(SDX) ; Get evalua tion and m anagement  codes"RTN" ,"SCRPW24" ,19,0) D A PEM^SCRPW2 41(.SDX)"R TN","SCRPW 24",20,0)  D NX Q"RTN ","SCRPW24 ",21,0) ;" RTN","SCRP W24",22,0) CLCG(SDX)  ;Get clini c group"RT N","SCRPW2 4",23,0) K  SDX S SDX =$P(SDOE0, U,4) I SDX  S SDX=$P( $G(^SC(SDX ,0)),U,31)  I SDX,$D( ^SD(409.67 ,SDX)) S S DX=SDX_U_$ P(^SD(409. 67,SDX,0), U) S:$L($P (SDX,U,2))  SDX(1)=SD X"RTN","SC RPW24",24, 0) D NX Q" RTN","SCRP W24",25,0)  ;"RTN","S CRPW24",26 ,0)CLCN(SD X) ;Get cl inic name" RTN","SCRP W24",27,0)  K SDX S S DX=$P(SDOE 0,U,4) I S DX S SDX=S DX_U_$P($G (^SC(SDX,0 )),U) I $L ($P(SDX,U, 2)) S SDX( 1)=SDX"RTN ","SCRPW24 ",28,0) D  NX Q"RTN", "SCRPW24", 29,0) ;"RT N","SCRPW2 4",30,0)CL CS(SDX) ;G et clinic  service"RT N","SCRPW2 4",31,0) K  SDX S SDX =$P(SDOE0, U,4) I SDX  S SDX=$P( $G(^SC(SDX ,0)),U,8)  D FST(.SDX ,44,9) S:$ L($P(SDX,U ,2)) SDX(1 )=SDX"RTN" ,"SCRPW24" ,32,0) D N X Q"RTN"," SCRPW24",3 3,0) ;"RTN ","SCRPW24 ",34,0)DXA D(SDX) ;Ge t all diag noses"RTN" ,"SCRPW24" ,35,0) K S DX N SDY,S DI D GETDX ^SDOE(SDOE ,"SDY") S  SDI=0"RTN" ,"SCRPW24" ,36,0) F   S SDI=$O(S DY(SDI)) Q :'SDI  S S DX=$P(SDY( SDI),U) I  SDX S SDX= SDX_U_$P($ $ICDDX^SCR PWICD(+SDX ,+SDOE0),U ,2) I $L($ P(SDX,U,2) ) D DXOTR  S SDX(SDI) =SDX"RTN", "SCRPW24", 37,0) D NX  Q"RTN","S CRPW24",38 ,0) ;"RTN" ,"SCRPW24" ,39,0)DXOT R ;Transfo rm diagnos is externa l value"RT N","SCRPW2 4",40,0) N  ENCDT"RTN ","SCRPW24 ",41,0) S  ENCDT=+$G( SDOE0)"RTN ","SCRPW24 ",42,0) I  'ENCDT D"R TN","SCRPW 24",43,0)  .I '$G(SDO E) S ENCDT =$$NOW^XLF DT() Q"RTN ","SCRPW24 ",44,0) .N  SDY"RTN", "SCRPW24", 45,0) .D G ETGEN^SDOE (SDOE,"SDY ")"RTN","S CRPW24",46 ,0) .S ENC DT=+$G(SDY (0))"RTN", "SCRPW24", 47,0) .K S DY"RTN","S CRPW24",48 ,0) S SDX= SDX_" "_$P ($$ICDDX^S CRPWICD(+S DX,ENCDT), U,4) Q"RTN ","SCRPW24 ",49,0) ;" RTN","SCRP W24",50,0) DXGS(SDX,S DZ) ;Get G AF score"R TN","SCRPW 24",51,0)  K SDX N SD I,SDY S SD Y=$S(SDZ=" H":$P($P(S DOE0,U),". "),1:DT)_. 9999,SDY=9 999999-SDY ,SDY=$O(^Y SD(627.8," AX5",$P(SD OE0,U,2),S DY))"RTN", "SCRPW24", 52,0) I SD Y S SDI=$O (^YSD(627. 8,"AX5",$P (SDOE0,U,2 ),SDY,""), -1) I SDI  S SDX=+$P( $G(^YSD(62 7.8,SDI,60 )),U,3) I  SDX S SDX( 1)=SDX_U_S DX"RTN","S CRPW24",53 ,0) D NX Q "RTN","SCR PW24",54,0 ) ;"RTN"," SCRPW24",5 5,0)DXGSQ( SDI) ;Set  up GAF hel p text"RTN ","SCRPW24 ",56,0) S  SDIRQ("?", 1)="Specif y a value  representi ng the Glo bal Assess ment of Fu nctioning  (GAF) scor e.""RTN"," SCRPW24",5 7,0) I SDI ="H" S SDI RQ("?")="S tatus as o f the enco unter date /time is u sed to det ermine 'hi storical'  values.""R TN","SCRPW 24",58,0)  I SDI="C"  S SDIRQ("? ")="Status  as of the  report ru n date is  used to de termine 'c urrent' va lues.""RTN ","SCRPW24 ",59,0) Q" RTN","SCRP W24",60,0)  ;"RTN","S CRPW24",61 ,0)DXPD(SD X) ;Get pr imary diag nosis"RTN" ,"SCRPW24" ,62,0) ;SD *5.3*329 f ixes probl em of repo rt not wor king for p rimary dx" RTN","SCRP W24",63,0)  K SDX N S DY,SDI D G ETDX^SDOE( SDOE,"SDY" ) S SDI=0" RTN","SCRP W24",64,0)  F  S SDI= $O(SDY(SDI )) Q:'SDI   S SDX=$P( SDY(SDI),U ) I SDX,$P (SDY(SDI), U,12)="P"  S SDX=SDX_ U_$P($$ICD DX^SCRPWIC D(+SDX,+SD OE0),U,2)  I $L($P(SD X,U,2)) D  DXOTR S SD X(SDI)=SDX "RTN","SCR PW24",65,0 ) D NX Q"R TN","SCRPW 24",66,0)  ;"RTN","SC RPW24",67, 0)DXSD(SDX ) ;Get sec ondary dia gnoses"RTN ","SCRPW24 ",68,0) ;S D*5.3*329  fixes prob lem of rep ort not wo rking for  secondary  dx"RTN","S CRPW24",69 ,0) K SDX  N SDY,SDI  D GETDX^SD OE(SDOE,"S DY") S SDI =0"RTN","S CRPW24",70 ,0) F  S S DI=$O(SDY( SDI)) Q:'S DI  S SDX= $P(SDY(SDI ),U) I SDX ,$P(SDY(SD I),U,12)'= "P" S SDX= SDX_U_$P($ $ICDDX^SCR PWICD(+SDX ,+SDOE0),U ,2) I $L($ P(SDX,U,2) ) D DXOTR  S SDX(SDI) =SDX"RTN", "SCRPW24", 71,0) D NX  Q"RTN","S CRPW24",72 ,0) ;"RTN" ,"SCRPW24" ,73,0)ENED (SDX,SDZ)  ;Get enrol lment date "RTN","SCR PW24",74,0 ) K SDX N  SDY S SDY= $$ENROL($S (SDZ="H":+ SDOE0,1:DT )) I SDY S  (SDX,Y)=$ P(SDY,U) X  ^DD("DD")  S SDX(1)= SDX_U_Y"RT N","SCRPW2 4",75,0) D  NX Q"RTN" ,"SCRPW24" ,76,0) ;"R TN","SCRPW 24",77,0)E NEF(SDX,SD Z) ;Get en rollment e ffective d ate"RTN"," SCRPW24",7 8,0) K SDX  N SDY S S DY=$$ENROL ($S(SDZ="H ":+SDOE0,1 :DT)) I SD Y S (SDX,Y )=$P(SDY,U ,8) X ^DD( "DD") S SD X(1)=SDX_U _Y"RTN","S CRPW24",79 ,0) D NX Q "RTN","SCR PW24",80,0 ) ;"RTN"," SCRPW24",8 1,0)ENEP(S DX,SDZ) ;G et enrollm ent priori ty"RTN","S CRPW24",82 ,0) K SDX  N SDY S SD Y=$$ENROL( $S(SDZ="H" :+SDOE0,1: DT)) I SDY  S SDX=$P( SDY,U,7) D  FST(.SDX, 27.11,.07)  S:$L($P(S DX,U,2)) S DX(1)=SDX" RTN","SCRP W24",83,0)  D NX Q"RT N","SCRPW2 4",84,0) ; "RTN","SCR PW24",85,0 )ENES(SDX, SDZ) ;Get  enrollment  status"RT N","SCRPW2 4",86,0) K  SDX N SDY  S SDY=$$E NROL($S(SD Z="H":+SDO E0,1:DT))  I SDY S SD X=$P(SDY,U ,4),SDX=SD X_U_$$EXTE RNAL^DILFD (27.11,.04 ,"F",SDX)  S:$L($P(SD X,U,2)) SD X(1)=SDX"R TN","SCRPW 24",87,0)  D NX Q"RTN ","SCRPW24 ",88,0) ;" RTN","SCRP W24",89,0) ENFR(SDX,S DZ) ;Get e nrollment  facility r eceived"RT N","SCRPW2 4",90,0) K  SDX N SDY  S SDY=$$E NROL($S(SD Z="H":+SDO E0,1:DT))  I SDY S SD X=$P(SDY,U ,6) I SDX  S SDX=SDX_ U_$P($G(^D IC(4,SDX,0 )),U) S:$L ($P(SDX,U, 2)) SDX(1) =SDX"RTN", "SCRPW24", 91,0) D NX  Q"RTN","S CRPW24",92 ,0) ;"RTN" ,"SCRPW24" ,93,0)ENSE (SDX,SDZ)  ;Get enrol lment sour ce of enro llment"RTN ","SCRPW24 ",94,0) K  SDX N SDY  S SDY=$$EN ROL($S(SDZ ="H":+SDOE 0,1:DT)) I  SDY S SDX =$P(SDY,U, 3) D FST(. SDX,27.11, .03) S:$L( $P(SDX,U,2 )) SDX(1)= SDX"RTN"," SCRPW24",9 5,0) D NX  Q"RTN","SC RPW24",96, 0) ;"RTN", "SCRPW24", 97,0)ENQ(S DZ) ;Set u p help tex t for enro llment"RTN ","SCRPW24 ",98,0) I  SDZ="H" S  SDIRQ("?") ="Enrollme nt status  as of the  encounter  date/time  is used fo r 'histori cal' value s.""RTN"," SCRPW24",9 9,0) I SDZ ="C" S SDI RQ("?")="E nrollment  status as  of the rep ort run da te is used  for 'curr ent' value s.""RTN"," SCRPW24",1 00,0) Q"RT N","SCRPW2 4",101,0)  ;"RTN","SC RPW24",102 ,0)OEAT(SD X) ;Get en counter ap pointment  type"RTN", "SCRPW24", 103,0) K S DX S SDX=$ P(SDOE0,U, 10) I SDX  S SDX=SDX_ U_$P($G(^S D(409.1,SD X,0)),U) S :$L($P(SDX ,U,2)) SDX (1)=SDX"RT N","SCRPW2 4",104,0)  D NX Q"RTN ","SCRPW24 ",105,0) ; "RTN","SCR PW24",106, 0)OEDV(SDX ) ;Get enc ounter div ision"RTN" ,"SCRPW24" ,107,0) K  SDX S SDX= $P(SDOE0,U ,11) I SDX  S SDX=SDX _U_$P($G(^ DG(40.8,SD X,0)),U) S :$L($P(SDX ,U,2)) SDX (1)=SDX"RT N","SCRPW2 4",108,0)  D NX Q"RTN ","SCRPW24 ",109,0) ; "RTN","SCR PW24",110, 0)OEEE(SDX ) ;Get enc ounter eli gibility"R TN","SCRPW 24",111,0)  K SDX S S DX=$P(SDOE 0,U,13) I  SDX S SDX= SDX_U_$P($ G(^DIC(8,S DX,0)),U)  S:$L($P(SD X,U,2)) SD X(1)=SDX"R TN","SCRPW 24",112,0)  D NX Q"RT N","SCRPW2 4",113,0)  ;"RTN","SC RPW24",114 ,0)OEOP(SD X) ;Get en counter or iginating  process ty pe"RTN","S CRPW24",11 5,0) K SDX  S SDX=$P( SDOE0,U,8)  D FST(.SD X,409.68,. 08) S:$L($ P(SDX,U,2) ) SDX(1)=S DX"RTN","S CRPW24",11 6,0) D NX  Q"RTN","SC RPW24",117 ,0) ;"RTN" ,"SCRPW24" ,118,0)OEP A(SDX) ;Ge t encounte r patient" RTN","SCRP W24",119,0 ) K SDX S  DFN=$P(SDO E0,U,2) I  DFN D DEM^ VADPT I $L (VADM(1))  S SDX(1)=D FN_U_VADM( 1)"RTN","S CRPW24",12 0,0) D NX  Q"RTN","SC RPW24",121 ,0) ;"RTN" ,"SCRPW24" ,122,0)OEE S(SDX) ;Ge t encounte r status"R TN","SCRPW 24",123,0)  K SDX S S DX=$P(SDOE 0,U,12) I  SDX S SDX= SDX_U_$P($ G(^SD(409. 63,SDX,0)) ,U) S:$L($ P(SDX,U,2) ) SDX(1)=S DX"RTN","S CRPW24",12 4,0) D NX  Q"RTN","SC RPW24",125 ,0) ;"RTN" ,"SCRPW24" ,126,0)OET S(SDX) ;Ge t transmis sion statu s"RTN","SC RPW24",127 ,0) K SDX  S SDX(1)=$ $STX^SCRPW 8(SDOE,SDO E0) Q"RTN" ,"SCRPW24" ,128,0) ;" RTN","SCRP W24",129,0 )TSQ(DIR)  ;Set up DI R array fo r transmis sion statu s question "RTN","SCR PW24",130, 0) K DIR S  DIR("A")= "Select tr ansmission  status",D IR("?")="T his value  represents  the trans mission st atus of th e encounte r record." "RTN","SCR PW24",131, 0) S DIR(0 )="SO^0:No t checked- out;1:No t ransmissio n record;2 :Not requi red, not t ransmitted ;3:Rejecte d for tran smission;4 :Awaiting  transmissi on;5:Trans mitted, no  acknowled gment;6:Tr ansmitted,  rejected; 7:Transmit ted, error ;8:Transmi tted, acce pted""RTN" ,"SCRPW24" ,132,0) Q" RTN","SCRP W24",133,0 ) ;"RTN"," SCRPW24",1 34,0)CLQ(D IR,SDZ) ;S et up DIR  array for  classifica tion quest ions        SD*5.3*63 1"RTN","SC RPW24",135 ,0) K DIR  S SDZ=$S(S DZ="A":"Ag ent Orange  exposure" ,SDZ="I":" ionizing r adiation e xposure",S DZ="S":"se rvice conn ected cond ition",SDZ ="C":"Camp  Lejeune", 1:"environ mental con taminants  exposure") "RTN","SCR PW24",136, 0) S DIR(0 )="SO^1:YE S;0:NO",DI R("A")="Tr eatment re lated to " _SDZ,DIR(" ?")="Indic ates if tr eatment wa s related  to "_SDZ Q "RTN","SCR PW24",137, 0) ;"RTN", "SCRPW24", 138,0)OECL (SDX,SDZ)  ;Get class ification  values      SD*5.3*63 1"RTN","SC RPW24",139 ,0) K SDX  N SDY S SD Z=$S(SDZ=" A":1,SDZ=" I":2,SDZ=" S":3,SDZ=" E":4,SDZ=" C":9,1:"")  I SDZ D C LASK^SDCO2 (SDOE,.SDY ) S SDX=$P ($G(SDY(SD Z)),U,2) I  $L(SDX) S  SDX(1)=$S (SDX=1:"1^ YES",1:"0^ NO")"RTN", "SCRPW24", 140,0) D N X Q"RTN"," SCRPW24",1 41,0) ;"RT N","SCRPW2 4",142,0)O EOU(SDX) ; Get option  used to c reate"RTN" ,"SCRPW24" ,143,0) K  SDX S SDX= +$P(SDOE0, U,5),SDX=+ $P($G(^AUP NVSIT(SDX, 0)),U,24)" RTN","SCRP W24",144,0 ) N SDY D  GETS^DIQ(1 9,SDX,.01, "","SDY")" RTN","SCRP W24",145,0 ) I 'SDX S  SDX="0^UN KNOWN",SDX (1)=SDX     ;SD*576"R TN","SCRPW 24",146,0)  I +SDX S  SDX=SDX_U_ SDY(19,SDX _",",.01)  S:$L($P(SD X,U,2)) SD X(1)=SDX"R TN","SCRPW 24",147,0)  D NX Q"RT N","SCRPW2 4",148,0)  ;"RTN","SC RPW24",149 ,0)SUQ(DIR ) ;Set up  DIR() arra y for Sche duled/unsc heduled qu estion"RTN ","SCRPW24 ",150,0) K  DIR S DIR ("A")="Sel ect outpat ient activ ity type", DIR("?",1) ="Only pre -scheduled  appointme nts will b e reflecte d as SCHED ULED.  All  other",DI R("?",2)=" types of a ctivity (a dd/edits,  registrati ons, walki ns or unsc heduled ac tivity)""R TN","SCRPW 24",151,0)  S DIR("?" )="will be  reflected  as UNSCHE DULED.",DI R(0)="SO^S :SCHEDULED ;U:UNSCHED ULED" Q"RT N","SCRPW2 4",152,0)  ;"RTN","SC RPW24",153 ,0)OESU(SD X) ;Get sc heduled/un scheduled  status"RTN ","SCRPW24 ",154,0) N  SDAP0 K S DX S SDX(1 )="""RTN", "SCRPW24", 155,0) I $ P(SDOE0,U, 8)=1 D  Q: $L(SDX(1)) "RTN","SCR PW24",156, 0) .S SDAP 0=$G(^DPT( +$P(SDOE0, U,2),"S",+ SDOE0,0))" RTN","SCRP W24",157,0 ) .Q:$P(SD AP0,U,20)' =SDOE  Q:$ P(SDAP0,U, 7)=4"RTN", "SCRPW24", 158,0) .S  SDX(1)="S^ SCHEDULED"  Q"RTN","S CRPW24",15 9,0) S SDX (1)="U^UNS CHEDULED"  Q"RTN","SC RPW24",160 ,0) ;"RTN" ,"SCRPW24" ,161,0)PCP R(SDX,SDZ)  ;Get prim ary care p rovider"RT N","SCRPW2 4",162,0)  ;Required  input: SDZ ="C" for c urrent, "H " for hist orical"RTN ","SCRPW24 ",163,0) K  SDX S SDX =$S(SDZ="C ":$$OUTPTP R^SDUTL3(+ $P(SDOE0,U ,2)),1:$$O UTPTPR^SDU TL3(+$P(SD OE0,U,2),+ $P(SDOE0,U ))) S:$L($ P(SDX,U,2) ) SDX(1)=S DX"RTN","S CRPW24",16 4,0) D NX  Q"RTN","SC RPW24",165 ,0) ;"RTN" ,"SCRPW24" ,166,0)PCT M(SDX,SDZ)  ;Get prim ary care t eam"RTN"," SCRPW24",1 67,0) ;Req uired inpu t: SDZ="C"  for curre nt, "H" fo r historic al"RTN","S CRPW24",16 8,0) K SDX  S SDX=$S( SDZ="C":$$ OUTPTTM^SD UTL3(+$P(S DOE0,U,2)) ,1:$$OUTPT TM^SDUTL3( +$P(SDOE0, U,2),+$P(S DOE0,U)))  S:$L($P(SD X,U,2)) SD X(1)=SDX"R TN","SCRPW 24",169,0)  D NX Q"RT N","SCRPW2 4",170,0)  ;"RTN","SC RPW24",171 ,0)PDPA(SD X) ;Get pa tient age" RTN","SCRP W24",172,0 ) K SDX S  DFN=$P(SDO E0,U,2) I  DFN D DEM^ VADPT I VA DM(4)=+VAD M(4) S SDX (1)=VADM(4 )_U_VADM(4 )"RTN","SC RPW24",173 ,0) D NX Q "RTN","SCR PW24",174, 0) ;"RTN", "SCRPW24", 175,0)PDPS (SDX) ;Get  patient s ex"RTN","S CRPW24",17 6,0) K SDX  S DFN=$P( SDOE0,U,2)  I DFN D D EM^VADPT I  $L($P(VAD M(5),U,2))  S SDX(1)= VADM(5)"RT N","SCRPW2 4",177,0)  D NX Q"RTN ","SCRPW24 ",178,0) ; "RTN","SCR PW24",179, 0)PDSC(SDX ) ;Get pat ient state /county"RT N","SCRPW2 4",180,0)  K SDX S DF N=$P(SDOE0 ,U,2) I DF N D ADD^VA DPT I $L($ P(VAPA(7), U,2)) S SD X(1)=$P(VA PA(5),U)_" ;"_$P(VAPA (7),U)_U_$ P(VAPA(5), U,2)_" / " _$P(VAPA(7 ),U,2)"RTN ","SCRPW24 ",181,0) D  NX Q"RTN" ,"SCRPW24" ,182,0) ;" RTN","SCRP W24",183,0 )PDZC(SDX)  ;Get pati ent zip co de"RTN","S CRPW24",18 4,0) K SDX  S DFN=$P( SDOE0,U,2)  I DFN D A DD^VADPT I  $L(VAPA(6 )) S SDX(1 )=VAPA(6)_ U_VAPA(6)" RTN","SCRP W24",185,0 ) D NX Q"R TN","SCRPW 24",186,0)  ;"RTN","S CRPW24",18 7,0)ENROL( SDATE)  ;G et enrollm ent record  (most rec ent to enc ounter dat e)"RTN","S CRPW24",18 8,0) ;SD/5 30 changed  For loop  and added  check for  zero node  to elimina te undefin ed error"R TN","SCRPW 24",189,0)  N SDY,SDI ,X1,X2,X,% Y"RTN","SC RPW24",190 ,0) S:SDAT E#1=0 SDAT E=SDATE+.9 999 S SDI= 0 F  S SDI =$O(^DGEN( 27.11,"C", +$P(SDOE0, U,2),SDI))  Q:'SDI  D "RTN","SCR PW24",191, 0) .Q:'$D( ^DGEN(27.1 1,SDI,0))" RTN","SCRP W24",192,0 ) .I '$D(^ DGEN(27.11 ,SDI,"U"))  S SDY=$G( ^DGEN(27.1 1,SDI,0)), SDY(+SDY)= SDY Q   ;S D*562"RTN" ,"SCRPW24" ,193,0) .S  SDY=$G(^D GEN(27.11, SDI,0)),SD Y($P($P(^D GEN(27.11, SDI,"U"),U ,1),".",1) )=SDY  ;SD /510 chang ed logic t o use date /time ente red"RTN"," SCRPW24",1 94,0) S SD I=$O(SDY(S DATE),-1)  Q:'SDI ""   S X1=$P($ P(SDOE0,U) ,"."),X2=S DI D ^%DTC  Q SDY(SDI )"RTN","SC RPW24",195 ,0) ;"RTN" ,"SCRPW24" ,196,0)NX  S:$D(SDX)< 10 SDX(1)= "~~~NONE~~ ~^~~~NONE~ ~~" Q"RTN" ,"SCRPW24" ,197,0) ;" RTN","SCRP W24",198,0 )FST(SDX,S DFI,SDFE)  ;Field set  transform "RTN","SCR PW24",199, 0) Q:'$L(S DX)  N SDY ,SDI D FIE LD^DID(SDF I,SDFE,"", "POINTER", "SDY") S S DY=SDY("PO INTER") F  SDI=1:1:$L (SDY,";")  I SDX=$P($ P(SDY,";", SDI),":")  S SDX=SDX_ U_$P($P(SD Y,";",SDI) ,":",2) Q" RTN","SCRP W24",200,0 ) Q"RTN"," SCRPW25")0 ^12^B75266 483"RTN"," SCRPW25",1 ,0)SCRPW25  ;RENO/KEI TH - ACRP  Ad Hoc Rep ort (cont. ) ; 12/5/0 0 4:15pm"R TN","SCRPW 25",2,0) ; ;5.3;Sched uling;**14 4,177,232, 631**;AUG  13, 1993;B uild 57"RT N","SCRPW2 5",3,0)PEA O(SDX) ;Ge t agent or ange indic ator"RTN", "SCRPW25", 4,0) K SDX  S DFN=$P( SDOE0,U,2)  I DFN D S VC^VADPT I  $L(VASV(2 )) S SDX(1 )=VASV(2)_ U_$S(VASV( 2):"YES",1 :"NO")"RTN ","SCRPW25 ",5,0) D N X Q"RTN"," SCRPW25",6 ,0) ;"RTN" ,"SCRPW25" ,7,0)PECL( SDX) ; Get  Camp Leje une indica tor  SD*5. 3*631"RTN" ,"SCRPW25" ,8,0) K SD X S DFN=$P (SDOE0,U,2 ) I DFN D  SVC^VADPT  I $G(VASV( 15))'="" S  SDX(1)=VA SV(15)_U_$ S(VASV(15) :"YES",1:" NO")"RTN", "SCRPW25", 9,0) D NX  Q"RTN","SC RPW25",10, 0) ;"RTN", "SCRPW25", 11,0)PEEC( SDX) ;Get  environmen tal contam inants ind icator"RTN ","SCRPW25 ",12,0) K  SDX S SDX= $P($G(^DPT ($P(SDOE0, U,2),.322) ),U,13) I  $L(SDX) D  FST(.SDX,2 ,.322013)  I $L($P(SD X,U,2)) S  SDX(1)=SDX "RTN","SCR PW25",13,0 ) D NX Q"R TN","SCRPW 25",14,0)  ;"RTN","SC RPW25",15, 0)PEIR(SDX ) ;Get ion izing radi ation indi cator"RTN" ,"SCRPW25" ,16,0) K S DX S DFN=$ P(SDOE0,U, 2) I DFN D  SVC^VADPT  I $L(VASV (3)) S SDX (1)=VASV(3 )_U_$S(VAS V(3):"YES" ,1:"NO")"R TN","SCRPW 25",17,0)  D NX Q"RTN ","SCRPW25 ",18,0) ;" RTN","SCRP W25",19,0) PEMT(SDX,S DZ) ;Get p atient mea ns test"RT N","SCRPW2 5",20,0) K  SDX N SDY  S SDX=$$L ST^DGMTU(+ $P(SDOE0,U ,2),$S(SDZ ="H":+$P(S DOE0,U),1: DT)) I $L( $P(SDX,U,4 )) S SDY=$ O(^DG(408. 32,"C",$P( SDX,U,4),0 )) I SDY S  SDX(1)=SD Y_U_$P(SDX ,U,3)"RTN" ,"SCRPW25" ,21,0) D N X Q"RTN"," SCRPW25",2 2,0) ;"RTN ","SCRPW25 ",23,0)PEM TQ(SDZ) ;S et up mean s test hel p text"RTN ","SCRPW25 ",24,0) I  SDZ="H" S  SDIRQ("?") ="Means Te st status  as of the  encounter  date/time  is used fo r 'histori cal' value s.""RTN"," SCRPW25",2 5,0) I SDZ ="C" S SDI RQ("?")="M eans Test  status as  of the rep ort run da te is used  for 'curr ent' value s.""RTN"," SCRPW25",2 6,0) Q"RTN ","SCRPW25 ",27,0) ;" RTN","SCRP W25",28,0) PEPE(SDX)  ;Get patie nt primary  eligibili ty"RTN","S CRPW25",29 ,0) K SDX  S DFN=$P(S DOE0,U,2)  I DFN D EL IG^VADPT I  $L($P(VAE L(1),U,2))  S SDX(1)= VAEL(1)"RT N","SCRPW2 5",30,0) D  NX Q"RTN" ,"SCRPW25" ,31,0) ;"R TN","SCRPW 25",32,0)P EAE(SDX) ; Get all pa tient elig ibilities" RTN","SCRP W25",33,0)  K SDX S D FN=$P(SDOE 0,U,2) I D FN D ELIG^ VADPT M SD X=VAEL(1)  I VAEL(1)  S SDX(+VAE L(1))=VAEL (1)"RTN"," SCRPW25",3 4,0) D NX  Q"RTN","SC RPW25",35, 0) ;"RTN", "SCRPW25", 36,0)PEPS( SDX) ;Get  patient pe riod of se rvice"RTN" ,"SCRPW25" ,37,0) K S DX S DFN=$ P(SDOE0,U, 2) I DFN D  ELIG^VADP T I $L($P( VAEL(2),U, 2)) S SDX( 1)=VAEL(2) "RTN","SCR PW25",38,0 ) D NX Q"R TN","SCRPW 25",39,0)  ;"RTN","SC RPW25",40, 0)PEPW(SDX ) ;Get pat ient POW i ndicated"R TN","SCRPW 25",41,0)  K SDX S DF N=$P(SDOE0 ,U,2) I DF N D SVC^VA DPT I $L(V ASV(4)) S  SDX(1)=VAS V(4)_U_$S( VASV(4)=1: "YES",1:"N O")"RTN"," SCRPW25",4 2,0) D NX  Q"RTN","SC RPW25",43, 0) ;"RTN", "SCRPW25", 44,0)PESP( SDX) ;Get  service co nnected pe rcentage"R TN","SCRPW 25",45,0)  K SDX S DF N=$P(SDOE0 ,U,2) I DF N D ELIG^V ADPT I VAE L(3) S SDX (1)=+$P(VA EL(3),U,2) _U_+$P(VAE L(3),U,2)" RTN","SCRP W25",46,0)  D NX Q"RT N","SCRPW2 5",47,0) ; "RTN","SCR PW25",48,0 )PEVT(SDX)  ;Get vete ran (y/n)? "RTN","SCR PW25",49,0 ) K SDX S  DFN=$P(SDO E0,U,2) I  DFN D ELIG ^VADPT I $ L(VAEL(4))  S SDX(1)= $S(VAEL(4) =1:"Y^YES" ,1:"N^NO") "RTN","SCR PW25",50,0 ) D NX Q"R TN","SCRPW 25",51,0)  ;"RTN","SC RPW25",52, 0)PRAP(SDX ) ;Get all  providers "RTN","SCR PW25",53,0 ) K SDX N  SDY,SDI D  GETPRV^SDO E(SDOE,"SD Y") S SDI= 0 F  S SDI =$O(SDY(SD I)) Q:'SDI   S SDX=$P (SDY(SDI), U),SDX=SDX _U_$P($G(^ VA(200,SDX ,0)),U) S: $L($P(SDX, U,2)) SDX( SDI)=SDX"R TN","SCRPW 25",54,0)  D NX Q"RTN ","SCRPW25 ",55,0) ;" RTN","SCRP W25",56,0) PRPC(SDX,S DP) ;Get p erson clas s"RTN","SC RPW25",57, 0) K SDX N  SDY,SDI D  GETPRV^SD OE(SDOE,"S DY") S SDI =0"RTN","S CRPW25",58 ,0) F  S S DI=$O(SDY( SDI)) Q:'S DI  S SDX= $P(SDY(SDI ),U,4) I $ S(SDP="P"& (SDX="P"): 1,SDP="S"& (SDX'="P") :1,SDP="A" :1,1:0) S  SDX=$P(SDY (SDI),U,6)  I SDX S S DX=SDX_U_$ P($$CODE2T XT^XUA4A72 (SDX),U) I  $L($P(SDX ,U,2)) D P COTR S SDX (SDI)=SDX  Q:SDP="P"" RTN","SCRP W25",59,0)  D NX Q"RT N","SCRPW2 5",60,0) ; "RTN","SCR PW25",61,0 )PCOTR ;Pe rson class  output tr ansform"RT N","SCRPW2 5",62,0) N  SDI,SDII, SDY S SDY= $G(^USC(89 32.1,+SDX, 0)) F SDI= 2,3 S SDII =$P(SDY,U, SDI) S:$L( SDII) SDX= SDX_"/"_SD II"RTN","S CRPW25",63 ,0) S SDX= $E(SDX,1,4 2) Q"RTN", "SCRPW25", 64,0) ;"RT N","SCRPW2 5",65,0)PR PP(SDX) ;G et primary  provider" RTN","SCRP W25",66,0)  K SDX N S DY,SDI D G ETPRV^SDOE (SDOE,"SDY ") S SDI=0  F  S SDI= $O(SDY(SDI )) Q:'SDI   I $P(SDY( SDI),U,4)= "P" S SDX= $P(SDY(SDI ),U),SDX=S DX_U_$P($G (^VA(200,S DX,0)),U)  S:$L($P(SD X,U,2)) SD X(SDI)=SDX  Q"RTN","S CRPW25",67 ,0) D NX Q "RTN","SCR PW25",68,0 ) ;"RTN"," SCRPW25",6 9,0)PRSP(S DX) ;Get s econdary p roviders"R TN","SCRPW 25",70,0)  K SDX N SD Y,SDI D GE TPRV^SDOE( SDOE,"SDY" ) S SDI=0  F  S SDI=$ O(SDY(SDI) ) Q:'SDI   I $P(SDY(S DI),U,4)'= "P" S SDX= $P(SDY(SDI ),U),SDX=S DX_U_$P($G (^VA(200,S DX,0)),U)  S:$L($P(SD X,U,2)) SD X(SDI)=SDX "RTN","SCR PW25",71,0 ) D NX Q"R TN","SCRPW 25",72,0)  ;"RTN","SC RPW25",73, 0)SCBC(SDX ) ;Get bot h stop cod es"RTN","S CRPW25",74 ,0) K SDX  S SDX=$P(S DOE0,U,3)  I SDX S SD X=SDX_U_$P ($G(^DIC(4 0.7,SDX,0) ),U) I $L( $P(SDX,U,2 )) D SCOTR  S SDX(1)= SDX"RTN"," SCRPW25",7 5,0) N SDI  S SDI=0 F   S SDI=$O (^SCE("APA R",SDOE,SD I)) Q:'SDI   S SDOECH =$$GETOE^S DOE(SDI) I  $P(SDOECH ,U,8)=4 S  SDX=$P(SDO ECH,U,3) I  SDX S SDX =SDX_U_$P( $G(^DIC(40 .7,SDX,0)) ,U) I $L($ P(SDX,U,2) ) D SCOTR  S SDX(2)=S DX"RTN","S CRPW25",76 ,0) D NX Q "RTN","SCR PW25",77,0 ) ;"RTN"," SCRPW25",7 8,0)SCPC(S DX) ;Get p rimary sto p code"RTN ","SCRPW25 ",79,0) K  SDX S SDX= $P(SDOE0,U ,3) I SDX  S SDX=SDX_ U_$P($G(^D IC(40.7,SD X,0)),U) I  $L($P(SDX ,U,2)) D S COTR S SDX (1)=SDX"RT N","SCRPW2 5",80,0) D  NX Q"RTN" ,"SCRPW25" ,81,0) ;"R TN","SCRPW 25",82,0)S CSC(SDX) ; Get second ary stop c ode"RTN"," SCRPW25",8 3,0) K SDX  N SDI S S DI=0 F  S  SDI=$O(^SC E("APAR",S DOE,SDI))  Q:'SDI  S  SDOECH=$$G ETOE^SDOE( SDI) I $P( SDOECH,U,8 )=4 S SDX= $P(SDOECH, U,3) I SDX  S SDX=SDX _U_$P($G(^ DIC(40.7,S DX,0)),U)  I $L($P(SD X,U,2)) D  SCOTR S SD X(2)=SDX"R TN","SCRPW 25",84,0)  D NX Q"RTN ","SCRPW25 ",85,0) ;" RTN","SCRP W25",86,0) SCOTR ;Tra nsform sto p code ext ernal valu e"RTN","SC RPW25",87, 0) S $P(SD X,U,2)=$P( ^DIC(40.7, +SDX,0),U, 2)_" "_$P( SDX,U,2) Q "RTN","SCR PW25",88,0 ) ;"RTN"," SCRPW25",8 9,0)SCCP(S DX) ;Get s top code c redit pair "RTN","SCR PW25",90,0 ) K SDX N  SDY D SCBC (.SDY) S S DX=$E($P(S DY(1),U,2) ,1,3) K:SD X'?3N SDX  I $D(SDX)  S SDX=SDX_ $E($P($G(S DY(2)),U,2 ),1,3) S:S DX'?6N SDX =$E(SDX,1, 3)_"000" D  CPOTR S S DX(1)=SDX" RTN","SCRP W25",91,0)  D NX Q"RT N","SCRPW2 5",92,0) ; "RTN","SCR PW25",93,0 )CPOTR ;Cr edit pair  output tra nsform"RTN ","SCRPW25 ",94,0) N  SDSC1,SDSC 2,SDZ"RTN" ,"SCRPW25" ,95,0) S S DSC1=$O(^D IC(40.7,"C ",$E(SDX,1 ,3),"")) Q :'SDSC1  S  SDSC1=$P( ^DIC(40.7, SDSC1,0),U ),SDSC1=$T R(SDSC1,"/ ","-")"RTN ","SCRPW25 ",96,0) I  $E(SDX,4,6 )="000" S  SDSC2="(NO NE)" G CPO 1"RTN","SC RPW25",97, 0) S SDSC2 =$O(^DIC(4 0.7,"C",$E (SDX,4,6), "")) Q:'SD SC2  S SDS C2=$P(^DIC (40.7,SDSC 2,0),U),SD SC2=$TR(SD SC2,"/","- ")"RTN","S CRPW25",98 ,0)CPO1 I  $L(SDSC1)< 17 S SDZ=S DSC1_"/"_$ E(SDSC2,1, (17+(17-$L (SDSC1))))  G CPOTQ"R TN","SCRPW 25",99,0)  I $L(SDSC2 )<17 S SDZ =$E(SDSC1, 1,(17+(17- $L(SDSC2)) ))_"/"_SDS C2 G CPOTQ "RTN","SCR PW25",100, 0) S SDZ=$ E(SDSC1,1, 17)_"/"_$E (SDSC2,1,1 7)"RTN","S CRPW25",10 1,0)CPOTQ  S $P(SDX,U ,2)=$P(SDX ,U)_" "_SD Z Q"RTN"," SCRPW25",1 02,0) ;"RT N","SCRPW2 5",103,0)V FEX(SDX) ; Get examin ations"RTN ","SCRPW25 ",104,0) K  SDX N SDY ,SDI S SDY =+$P(SDOE0 ,U,5),SDI= 0 F  S SDI =$O(^AUPNV XAM("AD",S DY,SDI)) Q :'SDI  S S DX=$P($G(^ AUPNVXAM(S DI,0)),U), SDX=SDX_U_ $P($G(^AUT TEXAM(+SDX ,0)),U) S: $L($P(SDX, U,2)) SDX( SDI)=SDX"R TN","SCRPW 25",105,0)  D NX Q"RT N","SCRPW2 5",106,0)  ;"RTN","SC RPW25",107 ,0)VFHF(SD X) ;Get he alth facto rs"RTN","S CRPW25",10 8,0) K SDX  N SDY,SDI  S SDY=+$P (SDOE0,U,5 ),SDI=0 F   S SDI=$O( ^AUPNVHF(" AD",SDY,SD I)) Q:'SDI   S SDX=$P ($G(^AUPNV HF(SDI,0)) ,U),SDX=SD X_U_$P($G( ^AUTTHF(+S DX,0)),U)  S:$L($P(SD X,U,2)) SD X(SDI)=SDX "RTN","SCR PW25",109, 0) D NX Q" RTN","SCRP W25",110,0 ) ;"RTN"," SCRPW25",1 11,0)VFIM( SDX) ;Get  immunizati ons"RTN"," SCRPW25",1 12,0) K SD X N SDY,SD I S SDY=+$ P(SDOE0,U, 5),SDI=0 F   S SDI=$O (^AUPNVIMM ("AD",SDY, SDI)) Q:'S DI  S SDX= $P($G(^AUP NVIMM(SDI, 0)),U),SDX =SDX_U_$P( $G(^AUTTIM M(+SDX,0)) ,U) S:$L($ P(SDX,U,2) ) SDX(SDI) =SDX"RTN", "SCRPW25", 113,0) D N X Q"RTN"," SCRPW25",1 14,0) ;"RT N","SCRPW2 5",115,0)V FPE(SDX) ; Get patien t educatio n"RTN","SC RPW25",116 ,0) K SDX  N SDY,SDI  S SDY=+$P( SDOE0,U,5) ,SDI=0 F   S SDI=$O(^ AUPNVPED(" AD",SDY,SD I)) Q:'SDI   S SDX=$P ($G(^AUPNV PED(SDI,0) ),U),SDX=S DX_U_$P($G (^AUTTEDT( +SDX,0)),U ) S:$L($P( SDX,U,2))  SDX(SDI)=S DX"RTN","S CRPW25",11 7,0) D NX  Q"RTN","SC RPW25",118 ,0) ;"RTN" ,"SCRPW25" ,119,0)VFS T(SDX) ;Ge t skin tes ts"RTN","S CRPW25",12 0,0) K SDX  N SDY,SDI  S SDY=+$P (SDOE0,U,5 ),SDI=0 F   S SDI=$O( ^AUPNVSK(" AD",SDY,SD I)) Q:'SDI   S SDX=$P ($G(^AUPNV SK(SDI,0)) ,U),SDX=SD X_U_$P($G( ^AUTTSK(+S DX,0)),U)  S:$L($P(SD X,U,2)) SD X(SDI)=SDX "RTN","SCR PW25",121, 0) D NX Q" RTN","SCRP W25",122,0 ) ;"RTN"," SCRPW25",1 23,0)VFTR( SDX) ;Get  treatments "RTN","SCR PW25",124, 0) K SDX N  SDY,SDI S  SDY=+$P(S DOE0,U,5), SDI=0 F  S  SDI=$O(^A UPNVTRT("A D",SDY,SDI )) Q:'SDI   S SDX=$P( $G(^AUPNVT RT(SDI,0)) ,U),SDX=SD X_U_$P($G( ^AUTTTRT(+ SDX,0)),U)  S:$L($P(S DX,U,2)) S DX(SDI)=SD X"RTN","SC RPW25",125 ,0) D NX Q "RTN","SCR PW25",126, 0) ;"RTN", "SCRPW25", 127,0)NX S :$D(SDX)<1 0 SDX(1)=" ~~~NONE~~~ ^~~~NONE~~ ~" Q"RTN", "SCRPW25", 128,0) ;"R TN","SCRPW 25",129,0) FST(SDX,SD FI,SDFE) ; Field set  transform" RTN","SCRP W25",130,0 ) Q:'$L(SD X)  N SDY, SDI D FIEL D^DID(SDFI ,SDFE,""," POINTER"," SDY") S SD Y=SDY("POI NTER") F S DI=1:1:$L( SDY,";") I  SDX=$P($P (SDY,";",S DI),":") S  SDX=SDX_U _$P($P(SDY ,";",SDI), ":",2) Q"R TN","SCRPW 25",131,0)  Q"RTN","S CRPW25",13 2,0) ;"RTN ","SCRPW25 ",133,0)VE TQ(DIR) ;S et up DIR  array for  'veteran?'  prompt"RT N","SCRPW2 5",134,0)  S DIR(0)=" SO^Y:YES;N :NO",DIR(" ?")="Indic ates if th e patient  served in  the U.S. a rmed force s." Q"RTN" ,"SCRPW25" ,135,0) ;" RTN","SCRP W25",136,0 )AOQ(DIR)  ;Set up DI R array fo r agent or ange promp t"RTN","SC RPW25",137 ,0) S DIR( 0)="SO^1:Y ES;0:NO",D IR("?")="I ndicates i f the pati ent was ex posed to a gent orang e." Q"RTN" ,"SCRPW25" ,138,0) ;" RTN","SCRP W25",139,0 )CLQ(DIR)  ; Set up D IR array f or Camp Le jeune prom pt  SD*5.3 *631"RTN", "SCRPW25", 140,0)  S  DIR(0)="SO ^1:YES;0:N O",DIR("?" )="Indicat es if the  patient tr eatment wa s related  to Camp Le jeune." Q" RTN","SCRP W25",141,0 ) ;"RTN"," SCRPW25",1 42,0)IRQ(D IR) ;Set u p DIR arra y for ioni zing radia tion promp t"RTN","SC RPW25",143 ,0) S DIR( 0)="SO^1:Y ES;0:NO",D IR("?")="I ndicates i f the pati ent was ex posed to i onizing ra diation."  Q"RTN","SC RPW25",144 ,0) ;"RTN" ,"SCRPW25" ,145,0)ECQ (DIR) ;Set  up DIR ar ray for en vironmenta l contamin ants promp t"RTN","SC RPW25",146 ,0) S DIR( 0)="SO^Y:Y ES;N:NO;U: UNKNOWN",D IR("?")="I ndicates i f the pati ent was ex posed to e nvironment al contami nants." Q" RTN","SCRP W25",147,0 ) ;"RTN"," SCRPW25",1 48,0)POWQ( DIR) ;Set  up DIR arr ay for POW  prompt"RT N","SCRPW2 5",149,0)  S DIR(0)=" SO^1:YES;0 :NO",DIR(" ?")="Indic ates if th e patient  was a pris oner of wa r." Q"RTN" ,"SCRPW25" ,150,0) ;" RTN","SCRP W25",151,0 )CPQ ;Cred it pair he lp text"RT N","SCRPW2 5",152,0)  S SDIRQ("? ",1)="Ente r a six di git numeri c value th at represe nts two va lid stop c odes, or a ",SDIRQ("? ",2)="vali d stop cod e followed  by three  zeros for  clinics th at do not  have a (se cond)",SDI RQ("?")="c redit stop  code.""RT N","SCRPW2 5",153,0)  Q  ; SD*5. 3*232 TEJ  - Q TO PRE VENT CPQ O VERRUN INT O PCAP 11/ 28/00"RTN" ,"SCRPW25" ,154,0) ;" RTN","SCRP W25",155,0 )PCAP(SDX, SDZ) ;Get  primary ca re associa te provide r"RTN","SC RPW25",156 ,0) ;Requi red input:  SDZ="C" f or current , "H" for  historical "RTN","SCR PW25",157, 0) N SDI,S DATE,SDLIS T,DFN"RTN" ,"SCRPW25" ,158,0) D  VARZ(SDZ)  S SDI=$$GE TALL^SCAPM CA(DFN,.SD ATE,SDLIST )"RTN","SC RPW25",159 ,0) S SDX= $P($G(^TMP ("SDPLIST" ,$J,DFN,"P CAP",1)),U ,1,2)"RTN" ,"SCRPW25" ,160,0) I  $L($P(SDX, U,2)) S SD X(1)=SDX"R TN","SCRPW 25",161,0)  K ^TMP("S DPLIST",$J ,DFN)"RTN" ,"SCRPW25" ,162,0) D  NX Q"RTN", "SCRPW25", 163,0) ;"R TN","SCRPW 25",164,0) NPCP(SDX,S DZ) ;Get n on-primary  care prov ider infor mation"RTN ","SCRPW25 ",165,0) ; Required i nput: SDZ= "C" for cu rrent, "H"  for histo rical"RTN" ,"SCRPW25" ,166,0) N  SDI,SDATE, SDLIST,DFN "RTN","SCR PW25",167, 0) D VARZ( SDZ) S SDI =$$GETALL^ SCAPMCA(DF N,.SDATE,S DLIST),SDI =0"RTN","S CRPW25",16 8,0) F  S  SDI=$O(^TM P("SDPLIST ",$J,DFN," NPCPR",SDI )) Q:'SDI   D"RTN","S CRPW25",16 9,0) .S SD X=$P($G(^T MP("SDPLIS T",$J,DFN, "NPCPR",SD I)),U,1,2) "RTN","SCR PW25",170, 0) .I $L($ P(SDX,U,2) ) S SDX(SD I)=SDX"RTN ","SCRPW25 ",171,0) . Q"RTN","SC RPW25",172 ,0) K ^TMP ("SDPLIST" ,$J,DFN)"R TN","SCRPW 25",173,0)  D NX Q"RT N","SCRPW2 5",174,0)  ;"RTN","SC RPW25",175 ,0)NPCT(SD X,SDZ) ;Ge t non-prim ary care t eam inform ation"RTN" ,"SCRPW25" ,176,0) ;R equired in put: SDZ=" C" for cur rent, "H"  for histor ical"RTN", "SCRPW25", 177,0) N S DI,SDATE,S DLIST,DFN" RTN","SCRP W25",178,0 ) D VARZ(S DZ) S SDI= $$GETALL^S CAPMCA(DFN ,.SDATE,SD LIST),SDI= 0"RTN","SC RPW25",179 ,0) F  S S DI=$O(^TMP ("SDPLIST" ,$J,DFN,"N PCTM",SDI) ) Q:'SDI   D"RTN","SC RPW25",180 ,0) .S SDX =$P($G(^TM P("SDPLIST ",$J,DFN," NPCTM",SDI )),U,1,2)" RTN","SCRP W25",181,0 ) .I $L($P (SDX,U,2))  S SDX(SDI )=SDX"RTN" ,"SCRPW25" ,182,0) .Q "RTN","SCR PW25",183, 0) K ^TMP( "SDPLIST", $J,DFN)"RT N","SCRPW2 5",184,0)  D NX Q"RTN ","SCRPW25 ",185,0) ; "RTN","SCR PW25",186, 0)VARZ(SDZ ) ;Produce  variables "RTN","SCR PW25",187, 0) ;Input:  SDZ="C" f or current , "H" for  historical "RTN","SCR PW25",188, 0) S SDLIS T="^TMP("" SDPLIST"", $J)",DFN=+ $P(SDOE0,U ,2) K SDX, @SDLIST"RT N","SCRPW2 5",189,0)  S SDATE=$S (SDZ="C":D T,1:+$P(SD OE0,U))"RT N","SCRPW2 5",190,0)  S (SDATE(" BEGIN"),SD ATE("END") )=SDATE,SD ATE="SDATE ""RTN","SC RPW25",191 ,0) Q"RTN" ,"SD53631P ")0^^B2014 479"RTN"," SD53631P", 1,0)SD5363 1P ;ALB/JE O - PRE/PO ST INSTALL  ROUTINE;0 5 Dec 2017   11:08 AM "RTN","SD5 3631P",2,0 ) ;;5.3;Sc heduling;* *631**;Apr  15, 2015; Build 57"R TN","SD536 31P",3,0)  ;"RTN","SD 53631P",4, 0) ;The bu lk of this  routine w as copied  from routi ne SD53293 "RTN","SD5 3631P",5,0 ) ;"RTN"," SD53631P", 6,0)MAIN ;  Main entr y point of  pre init" RTN","SD53 631P",7,0)  ;Change H L7 applica tion name" RTN","SD53 631P",8,0)  D HLAPP(" AMBCARE-DH 441","AMBC ARE-DH631" )"RTN","SD 53631P",9, 0) Q"RTN", "SD53631P" ,10,0) ;"R TN","SD536 31P",11,0) HLAPP(OLDN AME,NEWNAM E) ;Change  HL7 appli cation nam e"RTN","SD 53631P",12 ,0) ;Input   : OLDNAM E - Name o f HL7 appl ication to  change"RT N","SD5363 1P",13,0)  ;          NEWNAME -  New name f or HL7 app lication"R TN","SD536 31P",14,0)  ;Output :  None"RTN" ,"SD53631P ",15,0) ;N otes  : Ca ll designe d to be us ed as a KI DS pre/pos t init"RTN ","SD53631 P",16,0) S  OLDNAME=$ G(OLDNAME)  Q:OLDNAME ="""RTN"," SD53631P", 17,0) S NE WNAME=$G(N EWNAME) Q: NEWNAME="" "RTN","SD5 3631P",18, 0) N DIE,D IC,DA,DR,X ,Y"RTN","S D53631P",1 9,0) D BME S^XPDUTL(" Changing H L7 Applica tion name  from "_OLD NAME_" to  "_NEWNAME) "RTN","SD5 3631P",20, 0) I $D(^H L(771,"B", NEWNAME))  G ALRDY"RT N","SD5363 1P",21,0)  S DIC="^HL (771,""RTN ","SD53631 P",22,0) S  DIC(0)="X ""RTN","SD 53631P",23 ,0) S X=OL DNAME"RTN" ,"SD53631P ",24,0) D  ^DIC"RTN", "SD53631P" ,25,0) I ( Y<0) D  Q" RTN","SD53 631P",26,0 ) .D BMES^ XPDUTL("    *** "_OLD NAME_" app lication n ot found * **")"RTN", "SD53631P" ,27,0) S D IE=DIC"RTN ","SD53631 P",28,0) S  DA=+Y"RTN ","SD53631 P",29,0) S  DR=".01// /^S X=NEWN AME""RTN", "SD53631P" ,30,0) D ^ DIE"RTN"," SD53631P", 31,0) D ME S^XPDUTL(" HL7 applic ation name  successfu lly change d to "_NEW NAME)"RTN" ,"SD53631P ",32,0) Q" RTN","SD53 631P",33,0 ) ;"RTN"," SD53631P", 34,0)ALRDY  ;DH631 AL READY EXIS TS"RTN","S D53631P",3 5,0) D BME S^XPDUTL(" HL7 applic ation name  "_NEWNAME _" already  exists.") "RTN","SD5 3631P",36, 0) Q"RTN", "SDAMEP2") 0^15^B3176 5792"RTN", "SDAMEP2", 1,0)SDAMEP 2 ;ALB/CAW  - Extende d Display  (Patient D ata) ; 11/ 13/02"RTN" ,"SDAMEP2" ,2,0) ;;5. 3;Scheduli ng;**258,3 25,441,631 **;Aug 13,  1993;Buil d 57"RTN", "SDAMEP2", 3,0) ;"RTN ","SDAMEP2 ",4,0)PDAT A ; Patien t Data"RTN ","SDAMEP2 ",5,0) F S D=0,.11,.1 3,.32,.322 ,.321,.321 7,.36,.52  S SD(SD)=$ G(^DPT(DFN ,SD))    ; SD*5.3*631 "RTN","SDA MEP2",6,0)  S SD("CV" )=$$CVEDT^ DGCV(DFN,S DT)"RTN"," SDAMEP2",7 ,0) S VAIP ("D")="L", VAIP("L")= "" D INP^D GPMV10"RTN ","SDAMEP2 ",8,0) S S DFSTCOL=16 ,SDSECCOL= 60"RTN","S DAMEP2",9, 0) S X=""  D SET^SDAM EP1($$SETS TR^VALM1(" *** Patien t Informat ion ***",X ,25,30))"R TN","SDAME P2",10,0)  D CNTRL^VA LM10(SDLN, 25,30,IOIN HI,IOINORM )"RTN","SD AMEP2",11, 0)PTDOB ;  Date of Bi rth and SS N Info"RTN ","SDAMEP2 ",12,0) ;" RTN","SDAM EP2",13,0)  S X="",X= $$SETSTR^V ALM1("Date  of Birth: ",X,1,14)" RTN","SDAM EP2",14,0)  S X=$$SET STR^VALM1( $$FTIME^VA LM1($P(SD( 0),U,3)),X ,SDFSTCOL, 18)"RTN"," SDAMEP2",1 5,0) S X=$ $SETSTR^VA LM1(" ID:" ,X,55,4)"R TN","SDAME P2",16,0)  S X=$$SETS TR^VALM1(V A("PID"),X ,SDSECCOL, 20)"RTN"," SDAMEP2",1 7,0) D SET ^SDAMEP1(X )"RTN","SD AMEP2",18, 0)PTSEX ;  Sex and Ma rital Stat us Info"RT N","SDAMEP 2",19,0) ; "RTN","SDA MEP2",20,0 ) S X="",X =$$SETSTR^ VALM1("Sex :",X,11,4) "RTN","SDA MEP2",21,0 ) S X=$$SE TSTR^VALM1 ($S($P(SD( 0),U,2)="F ":"FEMALE" ,$P(SD(0), U,2)="M":" MALE",1:"U NKNOWN"),X ,SDFSTCOL, 18)"RTN"," SDAMEP2",2 2,0) S X=$ $SETSTR^VA LM1("Marit al Status: ",X,44,15) "RTN","SDA MEP2",23,0 ) S X=$$SE TSTR^VALM1 ($P($G(^DI C(11,+$P(S D(0),U,5), 0)),U),X,S DSECCOL,20 )"RTN","SD AMEP2",24, 0) D SET^S DAMEP1(X)" RTN","SDAM EP2",25,0) PTREL ; Re ligious Pr ef. Info"R TN","SDAME P2",26,0)  ;"RTN","SD AMEP2",27, 0) S X="", X=$$SETSTR ^VALM1("Re ligious Pr ef.:",X,43 ,16)"RTN", "SDAMEP2", 28,0) S X= $$SETSTR^V ALM1($P($G (^DIC(13,+ $P(SD(0),U ,8),0)),U) ,X,SDSECCO L,20)"RTN" ,"SDAMEP2" ,29,0) D S ET^SDAMEP1 (X)"RTN"," SDAMEP2",3 0,0)PTMT ;  Means Tes t Info"RTN ","SDAMEP2 ",31,0) ;" RTN","SDAM EP2",32,0)  S SDMT=$$ LST^DGMTU( DFN),X=""  G:$P(SDMT, U,4)="N" P TCO I +SDM T D  G PTM TQ"RTN","S DAMEP2",33 ,0) .S X=$ $SETSTR^VA LM1("Means  Test:",X, 4,11)"RTN" ,"SDAMEP2" ,34,0) .S  X=$$SETSTR ^VALM1($P( $$FMT^SDUT L2(DFN),U) ,X,SDFSTCO L,20)"RTN" ,"SDAMEP2" ,35,0) .S  X=$$SETSTR ^VALM1("La st Means T est:",X,43 ,16)"RTN", "SDAMEP2", 36,0) .S X =$$SETSTR^ VALM1($$FD ATE^VALM1( $P(SDMT,U, 2)),X,SDSE CCOL,20)"R TN","SDAME P2",37,0)P TCO S SDMT =$$LST^DGM TU(DFN,"", 2),X="" I  +SDMT D"RT N","SDAMEP 2",38,0) . S X=$$SETS TR^VALM1(" Co-Pay Tes t:",X,3,12 )"RTN","SD AMEP2",39, 0) .S X=$$ SETSTR^VAL M1($P($$FC O^SDUTL2(D FN),U,2),X ,SDFSTCOL, 10)"RTN"," SDAMEP2",4 0,0) .S X= $$SETSTR^V ALM1("Last  Co-Pay Te st:",X,42, 17)"RTN"," SDAMEP2",4 1,0) .S X= $$SETSTR^V ALM1($$FDA TE^VALM1($ P(SDMT,U,2 )),X,SDSEC COL,20)"RT N","SDAMEP 2",42,0)PT MTQ D SET^ SDAMEP1(X) "RTN","SDA MEP2",43,0 )PTELG ; P rimary Eli gibility a nd Period  of Service  Info"RTN" ,"SDAMEP2" ,44,0) ;"R TN","SDAME P2",45,0)  S X="",X=$ $SETSTR^VA LM1("Prima ry Elig.:" ,X,1,14)"R TN","SDAME P2",46,0)  S X=$$SETS TR^VALM1($ P($G(^DIC( 8,+$P(SD(. 36),U),0)) ,U,6),X,SD FSTCOL,21) "RTN","SDA MEP2",47,0 ) S X=$$SE TSTR^VALM1 ("POS:",X, 55,4)"RTN" ,"SDAMEP2" ,48,0) S X =$$SETSTR^ VALM1($P($ G(^DIC(21, +$P(SD(.32 ),U,3),0)) ,U),X,SDSE CCOL,20)"R TN","SDAME P2",49,0)  D SET^SDAM EP1(X)"RTN ","SDAMEP2 ",50,0)PTA DD ; Patie nt Address "RTN","SDA MEP2",51,0 ) ;"RTN"," SDAMEP2",5 2,0) S X=" ",X=($$SET STR^VALM1( "Address:" ,X,7,8))"R TN","SDAME P2",53,0)  S X=$$SETS TR^VALM1(" Phone:",X, 53,6)"RTN" ,"SDAMEP2" ,54,0) S X =$$SETSTR^ VALM1($P(S D(.13),U), X,SDSECCOL ,20)"RTN", "SDAMEP2", 55,0) D SE T^SDAMEP1( X)"RTN","S DAMEP2",56 ,0) S X="" ,X=($$SETS TR^VALM1($ P(SD(.11), U),X,10,30 ))"RTN","S DAMEP2",57 ,0) S X=$$ SETSTR^VAL M1("Cell P hone:",X,4 8,11)"RTN" ,"SDAMEP2" ,58,0) S X =$$SETSTR^ VALM1($S(( $P(SD(.13) ,U,4)'="") :$P(SD(.13 ),U,4),1:" UNANSWERED "),X,SDSEC COL,20)"RT N","SDAMEP 2",59,0) D  SET^SDAME P1(X)"RTN" ,"SDAMEP2" ,60,0) S X ="",SDPAGF LG=0"RTN", "SDAMEP2", 61,0) I $P (SD(.11),U ,2)'="" D" RTN","SDAM EP2",62,0)  .S X="",X =($$SETSTR ^VALM1($P( SD(.11),U, 2),X,10,30 ))"RTN","S DAMEP2",63 ,0) .S X=$ $SETSTR^VA LM1("Pager  #:",X,51, 8)"RTN","S DAMEP2",64 ,0) .S X=$ $SETSTR^VA LM1($S(($P (SD(.13),U ,5)'=""):$ P(SD(.13), U,5),1:"UN ANSWERED") ,X,SDSECCO L,20),SDPA GFLG=1"RTN ","SDAMEP2 ",65,0) D: X'="" SET^ SDAMEP1(X) "RTN","SDA MEP2",66,0 ) ; retrie ve country  info -- P ERM countr y is piece  10 of .11 "RTN","SDA MEP2",67,0 ) N FILE,C NTRY,FORIE N,FOREIGN" RTN","SDAM EP2",68,0)  S FILE=77 9.004,FORI EN=$P(SD(. 11),U,10), CNTRY=$$GE T1^DIQ(FIL E,FORIEN_" ,",2),CNTR Y=$$UPPER^ VALM1(CNTR Y),FOREIGN =$$FORIEN^ DGADDUTL(F ORIEN)"RTN ","SDAMEP2 ",69,0) I  'FOREIGN D  "RTN","SD AMEP2",70, 0) . N SDZ IP S SDZIP =$P(SD(.11 ),U,12) S: $E(SDZIP,6 ,10)'="" S DZIP=$E(SD ZIP,1,5)_" -"_$E(SDZI P,6,10)"RT N","SDAMEP 2",71,0) .  S X="",X= ($$SETSTR^ VALM1($P(S D(.11),U,4 )_", "_$P( $G(^DIC(5, +$P(SD(.11 ),U,5),0)) ,U)_"  "_S DZIP,X,10, 45))"RTN", "SDAMEP2", 72,0) E  D "RTN","SDA MEP2",73,0 ) . S X="" ,X=($$SETS TR^VALM1($ P(SD(.11), U,9)_" "_$ P(SD(.11), U,4)_" "_$ P(SD(.11), U,8),X,10, 45))"RTN", "SDAMEP2", 74,0) I 'S DPAGFLG D" RTN","SDAM EP2",75,0)  .S X=$$SE TSTR^VALM1 ("Pager #: ",X,51,8)" RTN","SDAM EP2",76,0)  .S X=$$SE TSTR^VALM1 ($S(($P(SD (.13),U,5) '=""):$P(S D(.13),U,5 ),1:"UNANS WERED"),X, SDSECCOL,2 0)"RTN","S DAMEP2",77 ,0) D SET^ SDAMEP1(X)  K SDPAGFL G"RTN","SD AMEP2",78, 0) S X="", X=$$SETSTR ^VALM1(CNT RY,X,10,45 )"RTN","SD AMEP2",79, 0) D SET^S DAMEP1(X)" RTN","SDAM EP2",80,0)  S X="",X= $$SETSTR^V ALM1("EMAI L ADDRESS: ",X,1,14)" RTN","SDAM EP2",81,0)  S X=$$SET STR^VALM1( $S(($P(SD( .13),U,3)' =""):$P(SD (.13),U,3) ,1:"UNANSW ERED"),X,S DFSTCOL,45 )"RTN","SD AMEP2",82, 0) D SET^S DAMEP1(X)" RTN","SDAM EP2",83,0) PTEXP ; Ra diation an d Status"R TN","SDAME P2",84,0)  ;"RTN","SD AMEP2",85, 0) S X="", X=$$SETSTR ^VALM1("Ra diation Ex posure:",X ,1,19)"RTN ","SDAMEP2 ",86,0) S  X=$$SETSTR ^VALM1($$F YNUNK^SDUT L2($P(SD(. 321),U,3)) ,X,21,7)"R TN","SDAME P2",87,0)  S X=$$SETS TR^VALM1(" Status:",X ,52,7)"RTN ","SDAMEP2 ",88,0) S  A=$S("^3^5 ^"[("^"_+D GPMVI(2)_" ^"):0,1:+D GPMVI(2)), SDST=$S('A :"IN",1:"" )_"ACTIVE  ",SDSTA=$S ("^4^5^"[( "^"_+DGPMV I(2)_"^"): "LODGER",1 :"INPATIEN T")"RTN"," SDAMEP2",8 9,0) I '$D (^DGPM("C" ,DFN)) S S DST="NO IN PT./LOD. A CT.",SDSTA ="""RTN"," SDAMEP2",9 0,0) S X=$ $SETSTR^VA LM1(SDST_S DSTA,X,SDS ECCOL,20)" RTN","SDAM EP2",91,0)  D SET^SDA MEP1(X)"RT N","SDAMEP 2",92,0)PT POW ; Pris oner of Wa r Info and  Last Admi ssion Date "RTN","SDA MEP2",93,0 ) ;"RTN"," SDAMEP2",9 4,0) S X=" ",X=$$SETS TR^VALM1(" Prisoner o f War:",X, 4,16)"RTN" ,"SDAMEP2" ,95,0) S X =$$SETSTR^ VALM1($$FY NUNK^SDUTL 2($P(SD(.5 2),U,5)),X ,21,7)"RTN ","SDAMEP2 ",96,0) S  X=$$SETSTR ^VALM1("La st Admit/L odger Date :",X,36,23 )"RTN","SD AMEP2",97, 0) I +DGPM VI(13,1) S  X=$$SETST R^VALM1($$ FTIME^VALM 1(+DGPMVI( 13,1)),X,S DSECCOL,18 )"RTN","SD AMEP2",98, 0) D SET^S DAMEP1(X)" RTN","SDAM EP2",99,0) PTAO ; Age nt Orange  Exposure a nd Last Di scharge Da te"RTN","S DAMEP2",10 0,0) S X=" ",X=$$SETS TR^VALM1(" AO Exp/Loc :",X,9,11) "RTN","SDA MEP2",101, 0) S X=$$S ETSTR^VALM 1($$FYNUNK ^SDUTL2($P (SD(.321), U,2))_$S($ P(SD(.321) ,U,13)="V" :"/VIET",$ P(SD(.321) ,U,13)="K" :"/DMZ",$P (SD(.321), U,13)="O": "/OTH",1:" "),X,21,14 )"RTN","SD AMEP2",102 ,0) S X=$$ SETSTR^VAL M1("Last D isch./Lodg er Date:", X,35,24)"R TN","SDAME P2",103,0)  S SDDISCH =+$G(^DGPM (+DGPMVI(1 7),0))"RTN ","SDAMEP2 ",104,0) I  +SDDISCH  S X=$$SETS TR^VALM1($ $FTIME^VAL M1(SDDISCH ),X,SDSECC OL,18)"RTN ","SDAMEP2 ",105,0) D  SET^SDAME P1(X)"RTN" ,"SDAMEP2" ,106,0)CV  ;Combat ve t"RTN","SD AMEP2",107 ,0) S X="" ,X=$$SETST R^VALM1("C ombat Vete ran:",X,5, 15)"RTN"," SDAMEP2",1 08,0) S X= $$SETSTR^V ALM1($$FYN UNK^SDUTL2 ($S($P(SD( "CV"),U,1) >0:"Y",1:" N")),X,21, 7)"RTN","S DAMEP2",10 9,0) S X=$ $SETSTR^VA LM1("Comba t Veteran  End Date:" ,X,35,24)" RTN","SDAM EP2",110,0 ) I $P(SD( "CV"),U,1) >0 D"RTN", "SDAMEP2", 111,0) .S  X=$$SETSTR ^VALM1($$F TIME^VALM1 ($P(SD("CV "),U,2)),X ,SDSECCOL, 18)"RTN"," SDAMEP2",1 12,0) E  S  X=$$SETST R^VALM1("N /A",X,SDSE CCOL,3)"RT N","SDAMEP 2",113,0)  D SET^SDAM EP1(X)"RTN ","SDAMEP2 ",114,0)SH AD ;PROJ 1 12/SHAD"RT N","SDAMEP 2",115,0)  S X="",X=$ $SETSTR^VA LM1("PROJ  112/SHAD:" ,X,6,14)"R TN","SDAME P2",116,0)  S X=$$SET STR^VALM1( $$FYNUNK^S DUTL2($S($ P(SD(.321) ,U,15)>0:" Y",1:"N")) ,X,21,7)"R TN","SDAME P2",117,0) SWASIA ;SW  Asia"RTN" ,"SDAMEP2" ,118,0) S  X=$$SETSTR ^VALM1("SW  Asia Cond itions:",X ,40,19)"RT N","SDAMEP 2",119,0)  S X=$$SETS TR^VALM1($ $FYNUNK^SD UTL2($P(SD (.322),U,1 3)),X,SDSE CCOL,20)"R TN","SDAME P2",120,0)  D SET^SDA MEP1(X)"RT N","SDAMEP 2",121,0)  ;D SET^SDA MEP1("")"R TN","SDAME P2",122,0) CLV ; CAMP  LEJEUNE                           SD*5.3*6 31 "RTN"," SDAMEP2",1 23,0) S X= "",X=$$SET STR^VALM1( "Camp Leje une:",X,7, 13)"RTN"," SDAMEP2",1 24,0) S X= $$SETSTR^V ALM1($$FYN UNK^SDUTL2 ($P(SD(.32 17),U)),X, 21,3)"RTN" ,"SDAMEP2" ,125,0) D  SET^SDAMEP 1(X)"RTN", "SDAMEP2", 126,0) D S ET^SDAMEP1 ("")"RTN", "SDAMEP2", 127,0) Q"R TN","SDAPI CO1")0^23^ B11063728" RTN","SDAP ICO1",1,0) SDAPICO1 ; ALB/MJK -  API - Comm on Check-O ut Process ing;04 MAR  1993 10:0 0 am"RTN", "SDAPICO1" ,2,0) ;;5. 3;Scheduli ng;**27,63 1**;08/13/ 93;Build 5 7"RTN","SD APICO1",3, 0) ;"RTN", "SDAPICO1" ,4,0)CLASS (SDOE) ; - - file cla ssificatio n data"RTN ","SDAPICO 1",5,0) IF  '$D(@SDRO OT@("CLASS IFICATION" )) G CLASS Q"RTN","SD APICO1",6, 0) N SDCLO EY,I,SDCTI S,SDCTS,SD VAL,SDCTVA L,SDCT,SDC T0,SDCTI,S DCTAB,SDAC T"RTN","SD APICO1",7, 0) ;  -- f ind class  required f or this en counter"RT N","SDAPIC O1",8,0) D  CLASK^SDC O2(SDOE,.S DCLOEY)"RT N","SDAPIC O1",9,0) ; "RTN","SDA PICO1",10, 0) ; -- ge t class ab breviation s"RTN","SD APICO1",11 ,0) S SDCT I=0 F  S S DCTI=$O(^S D(409.41,S DCTI)) Q:' SDCTI  S S DCTAB($P(^ (SDCTI,0), U,7))=SDCT I"RTN","SD APICO1",12 ,0) ;"RTN" ,"SDAPICO1 ",13,0) ;  -- process  deletions "RTN","SDA PICO1",14, 0) IF $D(S DCLOEY),$D (@SDROOT@( "CLASSIFIC ATION","DE LETE")) D" RTN","SDAP ICO1",15,0 ) . S SDCT ="""RTN"," SDAPICO1", 16,0) . F   S SDCT=$O (@SDROOT@( "CLASSIFIC ATION","DE LETE",SDCT )) Q:SDCT= ""  D"RTN" ,"SDAPICO1 ",17,0) ..  ; -- vali d class"RT N","SDAPIC O1",18,0)  .. S SDCTI =$$VALID(S DCT,.SDCTA B) Q:'SDCT I"RTN","SD APICO1",19 ,0) .. ; - - delete c o completi on date ;  delete cla ss entry ;  send warn ing"RTN"," SDAPICO1", 20,0) .. D  COMDT^SDC ODEL(SDOE) ,DEL^SDAPI CO(SDOE,40 9.42,SDCTI ),ERRFILE^ SDAPIER(10 45)"RTN"," SDAPICO1", 21,0) ;"RT N","SDAPIC O1",22,0)  ; -- warni ng if clas s data not  required  but passed "RTN","SDA PICO1",23, 0) IF '$D( SDCLOEY),$ D(@SDROOT@ ("CLASSIFI CATION","A DD"))!($D( @SDROOT@(" CLASSIFICA TION","CHA NGE"))) D  ERRFILE^SD APIER(1040 ) G CLASSQ "RTN","SDA PICO1",24, 0) ;"RTN", "SDAPICO1" ,25,0) F S DACT="ADD" ,"CHANGE"  D"RTN","SD APICO1",26 ,0) . S SD CT="""RTN" ,"SDAPICO1 ",27,0) .  F  S SDCT= $O(@SDROOT @("CLASSIF ICATION",S DACT,SDCT) ) Q:SDCT=" "  D"RTN", "SDAPICO1" ,28,0) ..  S SDVAL=@S DROOT@("CL ASSIFICATI ON",SDACT, SDCT)"RTN" ,"SDAPICO1 ",29,0) ..  ; -- vali d class ab brev passe d"RTN","SD APICO1",30 ,0) .. S S DCTI=$$VAL ID(SDCT,.S DCTAB) Q:' SDCTI"RTN" ,"SDAPICO1 ",31,0) ..  ; -- vali d format f or class v alue passe d"RTN","SD APICO1",32 ,0) .. S S DCT0=$G(^S D(409.41,S DCTI,0))"R TN","SDAPI CO1",33,0)  .. IF '$$ CHKVAL(SDC T0,.SDVAL)  D ERRFILE ^SDAPIER(1 044,$P(SDC T0,U)_U_SD VAL) Q"RTN ","SDAPICO 1",34,0) . . S SDCTVA L(SDCTI)=S DVAL"RTN", "SDAPICO1" ,35,0) ..  ; -- if ch ange to sc  class the n delete c /o process  date & se nd warning "RTN","SDA PICO1",36, 0) .. IF S DCTI=3,$G( SDCLOEY(3) ),$P(SDCLO EY(3),U,2) ]"",SDCTVA L(3)'=$P(S DCLOEY(3), U,2) D COM DT^SDCODEL (SDOE),ERR FILE^SDAPI ER(1046)"R TN","SDAPI CO1",37,0)  ;"RTN","S DAPICO1",3 8,0) ; --  get requir ed sequenc e to file  class (i.e . force sc  to be 1st )"RTN","SD APICO1",39 ,0) S SDCT IS=$$SEQ^S DCO21"RTN" ,"SDAPICO1 ",40,0) F  SDCTS=1:1  S SDCTI=+$ P(SDCTIS," ,",SDCTS)  Q:'SDCTI!( $D(SDCOQUI T))  D"RTN ","SDAPICO 1",41,0) .  ; -- chec k to see i f specific  class is  needed"RTN ","SDAPICO 1",42,0) .  IF $D(SDC TVAL(SDCTI )),'$D(SDC LOEY(SDCTI )) D ERRFI LE^SDAPIER (1047,$P($ G(^SD(409. 41,SDCTI,0 )),U,7)) Q "RTN","SDA PICO1",43, 0) . ; pro cess speci fic class" RTN","SDAP ICO1",44,0 ) . IF $D( SDCLOEY(SD CTI)) D"RT N","SDAPIC O1",45,0)  .. D ONE(S DCTI,SDCLO EY(SDCTI), SDOE,$G(SD CTVAL(SDCT I)))"RTN", "SDAPICO1" ,46,0) ..  ; -- if se rvice conn ected clas s do consi stency che cks"RTN"," SDAPICO1", 47,0) .. I F SDCTI=3  F I=1,2,4, 9 D SC^SDC O21(I,SDOE ,"",.SDCLO EY)           ; SD*5. 3*631"RTN" ,"SDAPICO1 ",48,0)CLA SSQ Q"RTN" ,"SDAPICO1 ",49,0) ;" RTN","SDAP ICO1",50,0 )VALID(SDC T,SDCTAB)  ; -- warni ng if not  a valid cl ass passed "RTN","SDA PICO1",51, 0) N SDCTI "RTN","SDA PICO1",52, 0) S SDCTI =+$G(SDCTA B(SDCT))"R TN","SDAPI CO1",53,0)  IF 'SDCTI  D ERRFILE ^SDAPIER(1 041,SDCT)" RTN","SDAP ICO1",54,0 ) Q SDCTI" RTN","SDAP ICO1",55,0 ) ;"RTN"," SDAPICO1", 56,0)ONE(S DCTI,SDATA ,SDOE,SDVA L) ;Proces s One Clas sification  at a time "RTN","SDA PICO1",57, 0) ; Input   -- SDCTI     Outpat ient Class ification  Type IEN"R TN","SDAPI CO1",58,0)  ;            SDATA     Null or  409.42 IEN ^Internal  Value^1=n/ a^1=unedt" RTN","SDAP ICO1",59,0 ) ;            SDOE      Outpati ent Encoun ter file I EN"RTN","S DAPICO1",6 0,0) ; Out put -- <no ne>"RTN"," SDAPICO1", 61,0) ;"RT N","SDAPIC O1",62,0)  N SDCT0,DI K,DA"RTN", "SDAPICO1" ,63,0) S S DCT0=$G(^S D(409.41,S DCTI,0)) G  ONEQ:SDCT 0']"""RTN" ,"SDAPICO1 ",64,0) ;  -- no long er applica ble"RTN"," SDAPICO1", 65,0) IF S DATA,$P(SD ATA,"^",3)  D  G ONEQ "RTN","SDA PICO1",66, 0) . N DIK ,DA"RTN"," SDAPICO1", 67,0) . S  DA=+SDATA, DIK="^SDD( 409.42," D  ^DIK"RTN" ,"SDAPICO1 ",68,0) .  D ERRFILE^ SDAPIER(10 42,$P(SDCT 0,U))"RTN" ,"SDAPICO1 ",69,0) ;  --  unedit able"RTN", "SDAPICO1" ,70,0) IF  SDATA,$P(S DATA,"^",4 ) D ERRFIL E^SDAPIER( 1043,$P(SD CT0,U)) G  ONEQ"RTN", "SDAPICO1" ,71,0) ; - - file dat a"RTN","SD APICO1",72 ,0) IF SDV AL]"" D FI LE^SDCO20( +SDATA,SDV AL)"RTN"," SDAPICO1", 73,0)ONEQ  Q"RTN","SD APICO1",74 ,0) ;"RTN" ,"SDAPICO1 ",75,0)CHK VAL(SDCT0, SDVAL) ; - - validate  classific ation valu e and conv ert"RTN"," SDAPICO1", 76,0) N Y, SDTYPE"RTN ","SDAPICO 1",77,0) S  SDTYPE=$P (SDCT0,U,3 ),Y=0"RTN" ,"SDAPICO1 ",78,0) IF  SDTYPE="Y ",SDVAL="Y "!(SDVAL=" N") S Y=1, SDVAL=$S(S DVAL="Y":1 ,1:0)"RTN" ,"SDAPICO1 ",79,0) IF  SDTYPE="N ",SDVAL=+S DVAL S Y=1 "RTN","SDA PICO1",80, 0) Q Y"RTN ","SDAPICO 1",81,0) ; "RTN","SDC O0")0^16^B 33156104"R TN","SDCO0 ",1,0)SDCO 0 ;ALB/RMO / - Build  List Area  - Check Ou t;11 FEB 1 993 10:00  am ; 6/22/ 05 12:56pm "RTN","SDC O0",2,0) ; ;5.3;Sched uling;**20 ,44,132,18 0,351,441, 586,631**; Aug 13, 19 93;Build 5 7"RTN","SD CO0",3,0)  ;"RTN","SD CO0",4,0)E N(SDARY,SD OE,SDSTART ,SDTOT) ;E ntry point  Called by  Ck Out &  Apt Mgr Ex p Dis"RTN" ,"SDCO0",5 ,0) S SDTO T=0"RTN"," SDCO0",6,0 ) D CL(SDA RY,SDOE,SD START,.SDT OT)"RTN"," SDCO0",7,0 ) D PR(SDA RY,SDOE,SD START,.SDT OT)"RTN"," SDCO0",8,0 ) D DX(SDA RY,SDOE,SD START,.SDT OT)"RTN"," SDCO0",9,0 ) I $P($G( ^SCE(+SDOE ,0)),"^",8 )'=2 D SC( SDARY,SDOE ,SDSTART,. SDTOT)"RTN ","SDCO0", 10,0) Q"RT N","SDCO0" ,11,0) ;"R TN","SDCO0 ",12,0)CL( SDARY,SDOE ,SDSTART,S DTOT) ;Bui ld classif ication (P g: 1  Row:  SDSTART-S DSTART+7   Col: 1-80) "RTN","SDC O0",13,0)  N SDCLOEY, SDCNI,SDCN T,SDCTI,SD CTIS,SDCTS ,SDEND,SDL INE,SDNA,S DVAL,X"RTN ","SDCO0", 14,0) S SD LINE=SDSTA RT,SDEND=S DSTART+9"R TN","SDCO0 ",15,0) D  SET(SDARY, SDLINE," C LASSIFICAT ION ",5,IO RVON,IORVO FF,"",""," ",.SDTOT)" RTN","SDCO 0",16,0) D  CLASK^SDC O2(SDOE,.S DCLOEY)"RT N","SDCO0" ,17,0) D S ET(SDARY,S DLINE,"["_ $S($D(SDCL OEY):"Requ ired",1:"N ot Require d")_"]",24 ,"","","", "","",.SDT OT)"RTN"," SDCO0",18, 0) S SDCNT =0,SDCTIS= $$SEQ^SDCO 21"RTN","S DCO0",19,0 ) F SDCTS= 1:1 S SDCT I=+$P(SDCT IS,",",SDC TS) Q:'SDC TI  D"RTN" ,"SDCO0",2 0,0) .S SD CNT=SDCNT+ 1,SDLINE=S DLINE+1"RT N","SDCO0" ,21,0) .S: $D(SDCLOEY (SDCTI)) S DVAL=$$VAL ^SDCODD(SD CTI,$P(SDC LOEY(SDCTI ),"^",2)), SDNA=+$P(S DCLOEY(SDC TI),"^",3) "RTN","SDC O0",22,0)  .S X=$S('$ D(SDCLOEY( SDCTI)):"N ot Applica ble",$$COM DT^SDCOU(S DOE)&(SDVA L=""):"Not  Applicabl e",SDVAL=" ":"Unanswe red",1:SDV AL)"RTN"," SDCO0",23, 0) .D SET( SDARY,SDLI NE,SDCNT_"   "_$J($P( $G(^SD(409 .41,SDCTI, 0)),"^",6) _": ",32)_ X,2,"","", "CL",SDCNT ,+$G(SDCLO EY(SDCTI)) _"^"_SDCTI ,.SDTOT)"R TN","SDCO0 ",24,0) F  SDLINE=SDL INE+1:1:SD END D SET( SDARY,SDLI NE,"",1,"" ,"","","", "",.SDTOT) "RTN","SDC O0",25,0)  Q"RTN","SD CO0",26,0)  ;"RTN","S DCO0",27,0 )PR(SDARY, SDOE,SDSTA RT,SDTOT)  ;Build Pro vider (Pg:  1  Row: S DSTART+8-E ND  Col: 1 -40)"RTN", "SDCO0",28 ,0) N SDCN T,SDLINE,S DPR,SDVPRV "RTN","SDC O0",29,0)  S SDLINE=S DSTART+10                           ;SD*.5. 3*631       "RTN","SD CO0",30,0)  D SET(SDA RY,SDLINE, " PROVIDER  ",5,IORVO N,IORVOFF, "","","",. SDTOT)"RTN ","SDCO0", 31,0) D SE T(SDARY,SD LINE,"["_$ S($$PRASK^ SDCO3(SDOE )=1:"Requi red",1:"No t Required ")_"]",18, "","",""," ","",.SDTO T)"RTN","S DCO0",32,0 ) ;"RTN"," SDCO0",33, 0) ; -- ge t provider  data"RTN" ,"SDCO0",3 4,0) D GET PRV^SDOE(S DOE,"SDPR" )"RTN","SD CO0",35,0)  S (SDCNT, SDVPRV)=0" RTN","SDCO 0",36,0) F   S SDVPRV =$O(SDPR(S DVPRV)) Q: 'SDVPRV  D "RTN","SDC O0",37,0)  . S SDCNT= SDCNT+1"RT N","SDCO0" ,38,0) . S  SDLINE=SD LINE+1"RTN ","SDCO0", 39,0) . D  SET(SDARY, SDLINE,SDC NT_"  "_$$ PR^SDCO31( +SDPR(SDVP RV)),2,"", "","PR",SD CNT,SDVPRV _"^"_+SDPR (SDVPRV),. SDTOT)"RTN ","SDCO0", 40,0) Q"RT N","SDCO0" ,41,0) ;"R TN","SDCO0 ",42,0)DX( SDARY,SDOE ,SDSTART,S DTOT) ;Bui ld Diagnos is (Pg: 1   Row: SDST ART+8-END   Col: 42-8 0)"RTN","S DCO0",43,0 ) N SDCNT, SDDXS,SDDX D,SDVPOV,S DLINE,ICDV DT,IMPDT,D XARY,TXT,I "RTN","SDC O0",44,0)  S SDLINE=S DSTART+10                              ; SD *5.3*631    "RTN","SD CO0",45,0)  D SET(SDA RY,SDLINE, " DIAGNOSI S ",45,IOR VON,IORVOF F,"","","" ,.SDTOT)"R TN","SDCO0 ",46,0) D  SET(SDARY, SDLINE,"[" _$S($$DXAS K^SDCO4(SD OE)=1:"Req uired",1:" Not Requir ed")_"]",5 9,"","","" ,"","",.SD TOT)"RTN", "SDCO0",47 ,0) ;"RTN" ,"SDCO0",4 8,0) ; --  get dxs da ta"RTN","S DCO0",49,0 ) D GETDX^ SDOE(SDOE, "SDDXS")"R TN","SDCO0 ",50,0) S  (SDCNT,SDV POV)=0"RTN ","SDCO0", 51,0) S IM PDT=$$IMP^ ICDEX(30)" RTN","SDCO 0",52,0) F   S SDVPOV =$O(SDDXS( SDVPOV)) Q :'SDVPOV   D"RTN","SD CO0",53,0)  . S SDCNT =SDCNT+1"R TN","SDCO0 ",54,0) .  S SDLINE=S DLINE+1"RT N","SDCO0" ,55,0) . S  ICDVDT=$S ($P(SDDXS( SDVPOV),"^ ",3)'="":$ $GET1^DIQ( 9000010,$P (SDDXS(SDV POV),"^",3 ),.01,"I") ,1:"")"RTN ","SDCO0", 56,0) . S  SDDXD=$$DX ^SDCO41(+S DDXS(SDVPO V),ICDVDT) "RTN","SDC O0",57,0)  . D SET(SD ARY,SDLINE ,SDCNT_"   "_$P(SDDXD ,"^"),42," ","","","" ,"",.SDTOT )"RTN","SD CO0",58,0)  . I ICDVD T<IMPDT D   Q"RTN","S DCO0",59,0 ) . . D SE T(SDARY,SD LINE,$P(SD DXD,"^",2) ,55,"","", "DX",SDCNT ,SDVPOV_"^ "_+SDDXS(S DVPOV),.SD TOT)"RTN", "SDCO0",60 ,0) . D DX FTXT($P(SD DXD,"^",2) ,.DXARY) S  I="" F  S  I=$O(DXAR Y(I)) Q:I= ""  S TXT= DXARY(I) D "RTN","SDC O0",61,0)  . . I I=1  D SET(SDAR Y,SDLINE,T XT,55,""," ","DX",SDC NT,SDVPOV_ "^"_+SDDXS (SDVPOV),. SDTOT) Q"R TN","SDCO0 ",62,0) .  . S SDLINE =SDLINE+1  D SET(SDAR Y,SDLINE,T XT,55,""," ","","","" ,.SDTOT)"R TN","SDCO0 ",63,0) Q" RTN","SDCO 0",64,0) ; "RTN","SDC O0",65,0)S C(SDARY,SD OEP,SDSTAR T,SDTOT) ; Build Stop  Codes (Pg : 2  Row:  SDTOT+1  C ol: 1-80)" RTN","SDCO 0",66,0) N  SDLINE,SD ONE"RTN"," SDCO0",67, 0) F SDLIN E=SDTOT+1: 1:SDSTART+ VALM("LINE S")+1 D SE T(SDARY,SD LINE,"",1, "","",""," ","",.SDTO T)"RTN","S DCO0",68,0 ) D SET(SD ARY,SDLINE ," STOP CO DES ",5,IO RVON,IORVO FF,"",""," ",.SDTOT)" RTN","SDCO 0",69,0) D  SET(SDARY ,SDLINE,"[ Stop Codes  Not Requi red / Proc edures Req uired]",28 ,"","","", "","",.SDT OT)"RTN"," SDCO0",70, 0) D AE(SD ARY,SDOEP, .SDLINE,.S DTOT,.SDON E)"RTN","S DCO0",71,0 ) S SDOE=0 "RTN","SDC O0",72,0)  F  S SDOE= $O(^SCE("A PAR",SDOEP ,SDOE)) Q: 'SDOE  D A E(SDARY,SD OE,.SDLINE ,.SDTOT,.S DONE)"RTN" ,"SDCO0",7 3,0) Q"RTN ","SDCO0", 74,0) ;"RT N","SDCO0" ,75,0)AE(S DARY,SDOE, SDLINE,SDT OT,SDONE)  ; -- add/e dits"RTN", "SDCO0",76 ,0) N SDOE 0,SDT,DFN, SDVIEN,CPT S,SDCNT,SD VCPT0,SDVC PT,SDSCD0, X"RTN","SD CO0",77,0)  S SDOE0=$ G(^SCE(+SD OE,0))"RTN ","SDCO0", 78,0) S SD T=+SDOE0"R TN","SDCO0 ",79,0) S  DFN=+$P(SD OE0,"^",2) "RTN","SDC O0",80,0)  S SDSC=+$P (SDOE0,U,3 )"RTN","SD CO0",81,0)  S SDCL=+$ P(SDOE0,U, 4)"RTN","S DCO0",82,0 ) S SDVIEN =+$P(SDOE0 ,U,5)"RTN" ,"SDCO0",8 3,0) ;"RTN ","SDCO0", 84,0) ; --  quit if v isit alrea dy process ed"RTN","S DCO0",85,0 ) G:$D(SDO NE(SDVIEN) ) AEQ"RTN" ,"SDCO0",8 6,0) ;"RTN ","SDCO0", 87,0) S SD SCD0=$G(^D IC(40.7,SD SC,0))"RTN ","SDCO0", 88,0) S SD LINE=SDLIN E+1"RTN"," SDCO0",89, 0) D SET(S DARY,SDLIN E,$P(SDSCD 0,"^",2)_"   "_$E($P( SDSCD0,"^" ),1,30),5, "","",""," ","",.SDTO T)"RTN","S DCO0",90,0 ) ;"RTN"," SDCO0",91, 0) ; -- ge t cpts and  loop"RTN" ,"SDCO0",9 2,0) D GET CPT^SDOE(S DOE,"CPTS" )"RTN","SD CO0",93,0)  S (SDCNT, SDVCPT)=0" RTN","SDCO 0",94,0) N  MODINFO,M ODPTR,MODT EXT,PTR,MO DCODE,CPTI NFO,ICPTVD T"RTN","SD CO0",95,0)  F  S SDVC PT=+$O(CPT S(SDVCPT))  Q:'SDVCPT   D"RTN"," SDCO0",96, 0) .; S SD VCPT0=$G(C PTS(SDVCPT ))"RTN","S DCO0",97,0 ) .; S SDC NT=SDCNT+1 "RTN","SDC O0",98,0)  . S SDLINE =SDLINE+1" RTN","SDCO 0",99,0) .  D SET(SDA RY,SDLINE, "Procedure (s):",12," ","","","" ,"",.SDTOT )"RTN","SD CO0",100,0 ) .;"RTN", "SDCO0",10 1,0) .; IF  $D(^ICPT( +SDVCPT0,0 )) S X=^(0 ) D"RTN"," SDCO0",102 ,0) .; N C PTINFO"RTN ","SDCO0", 103,0) . S  ICPTVDT=$ S($P(CPTS( SDVCPT),"^ ",3)'="":$ $GET1^DIQ( 9000010,$P (CPTS(SDVC PT),"^",3) ,.01,"I"), 1:"")"RTN" ,"SDCO0",1 04,0) . S  CPTINFO=$$ CPT^ICPTCO D(+$G(CPTS (SDVCPT)), ICPTVDT,1) "RTN","SDC O0",105,0)  . S:CPTIN FO>0 X=$P( CPTINFO,"^ ",2,99),X= $P(X,"^")_ " x "_$P($ G(CPTS(SDV CPT)),"^", 16)_"  "_$ P(X,"^",2) "RTN","SDC O0",106,0)  . S:CPTIN FO'>0 X="P rocedure n ot defined ""RTN","SD CO0",107,0 ) . ;"RTN" ,"SDCO0",1 08,0) . D  SET(SDARY, SDLINE,$E( X,1,40),27 ,"","","", "","",.SDT OT)"RTN"," SDCO0",109 ,0) . ;"RT N","SDCO0" ,110,0) .  ;Retrieve  Procedure  (CPT) Code s and asso ciated Mod ifiers"RTN ","SDCO0", 111,0) . S  PTR=0"RTN ","SDCO0", 112,0) . F   S PTR=+$ O(CPTS(SDV CPT,1,PTR) ) Q:'PTR   D"RTN","SD CO0",113,0 ) . . S MO DPTR=$G(CP TS(SDVCPT, 1,PTR,0))" RTN","SDCO 0",114,0)  . . Q:'MOD PTR"RTN"," SDCO0",115 ,0) . . S  MODINFO=$$ MOD^ICPTMO D(MODPTR," I",ICPTVDT ,1)"RTN"," SDCO0",116 ,0) . . Q: MODINFO'>0 "RTN","SDC O0",117,0)  . . S MOD CODE="-"_$ P(MODINFO, "^",2)"RTN ","SDCO0", 118,0) . .  S MODTEXT =$P(MODINF O,"^",3)"R TN","SDCO0 ",119,0) .  . S SDLIN E=SDLINE+1 "RTN","SDC O0",120,0)  . . D SET (SDARY,SDL INE,MODCOD E,29,"","" ,"","","", .SDTOT)"RT N","SDCO0" ,121,0) .  . D SET(SD ARY,SDLINE ,MODTEXT,3 8,"","","" ,"","",.SD TOT)"RTN", "SDCO0",12 2,0) . . Q "RTN","SDC O0",123,0)  ;"RTN","S DCO0",124, 0) ; -- se t indicato r that vis it was pro cessed"RTN ","SDCO0", 125,0) S S DONE(SDVIE N)="""RTN" ,"SDCO0",1 26,0)AEQ Q "RTN","SDC O0",127,0)  ;"RTN","S DCO0",128, 0)SET(SDAR Y,LINE,TEX T,COL,ON,O FF,SDSUB,S DCNT,SDATA ,SDTOT) ;  -- set dis play array "RTN","SDC O0",129,0)  N X"RTN", "SDCO0",13 0,0) S:LIN E>SDTOT SD TOT=LINE"R TN","SDCO0 ",131,0) S  X=$S($D(^ TMP(SDARY, $J,LINE,0) ):^(0),1:" ")"RTN","S DCO0",132, 0) S ^TMP( SDARY,$J,L INE,0)=$$S ETSTR^VALM 1(TEXT,X,C OL,$L(TEXT ))"RTN","S DCO0",133, 0) D:$G(ON )]""!($G(O FF)]"") CN TRL^VALM10 (LINE,COL, $L(TEXT),$ G(ON),$G(O FF))"RTN", "SDCO0",13 4,0) S:$G( SDSUB)]""  ^TMP("SDCO IDX",$J,SD SUB,SDCNT, SDLINE)=SD ATA,^TMP(" SDCOIDX",$ J,SDSUB,0) =SDCNT"RTN ","SDCO0", 135,0) Q"R TN","SDCO0 ",136,0)DX FTXT(DXTXT ,DXARY) ;  -- formatt ed diagnos is text"RT N","SDCO0" ,137,0) N  DIWL,DIWR, X"RTN","SD CO0",138,0 ) K ^UTILI TY($J,"W") ,DXARY"RTN ","SDCO0", 139,0) S D IWL=1,DIWR =26,X=$$SE NTENCE^XLF STR(DXTXT) "RTN","SDC O0",140,0)  D ^DIWP"R TN","SDCO0 ",141,0) S  X="""RTN" ,"SDCO0",1 42,0) F  S  X=$O(^UTI LITY($J,"W ",1,X)) Q: X=""  D"RT N","SDCO0" ,143,0) .  S DXARY(X) =$G(^UTILI TY($J,"W", 1,X,0))"RT N","SDCO0" ,144,0) K  ^UTILITY($ J,"W")"RTN ","SDCO0", 145,0) Q"R TN","SDCO2 ")0^24^B40 32333"RTN" ,"SDCO2",1 ,0)SDCO2 ; ALB/RMO -  Classifica tion - Che ck Out;30  DEC 1992 1 :10 pm"RTN ","SDCO2", 2,0) ;;5.3 ;Schedulin g;**27,132 ,631**;08/ 13/93;Buil d 57"RTN", "SDCO2",3, 0) ;"RTN", "SDCO2",4, 0)EN ;Entr y point fo r SDCO CLA SSIFICATIO N protocol "RTN","SDC O2",5,0) ;  Input  --  SDOE"RTN" ,"SDCO2",6 ,0) N I,SD CLI,SDCLOE Y,SDCOMF,S DCOQUIT,SD CTI,SDI,SD LINE,SDSEL ,SDSELY"RT N","SDCO2" ,7,0) S VA LMBCK="""R TN","SDCO2 ",8,0) ;"R TN","SDCO2 ",9,0) IF  '$$EDITOK^ SDCO3(SDOE ,1) G Q"RT N","SDCO2" ,10,0) ;"R TN","SDCO2 ",11,0) N  SDVISIT"RT N","SDCO2" ,12,0) S S DVISIT=$P( $G(^SCE(+S DOE,0)),U, 5)"RTN","S DCO2",13,0 ) S X=$$IN TV^PXAPI(" SCC","SD", "PIMS",SDV ISIT)"RTN" ,"SDCO2",1 4,0) D BLD ^SDCO S VA LMBCK="R"" RTN","SDCO 2",15,0)Q  Q"RTN","SD CO2",16,0)  ;"RTN","S DCO2",17,0 )ASK(SDOE, SDCLOEY,SD CLHDL,SDCO QUIT) ;Ask  Outpatien t Classifi cations"RT N","SDCO2" ,18,0) ; I nput  -- S DOE     Ou tpatient E ncounter f ile IEN"RT N","SDCO2" ,19,0) ;            S DCLOEY  Cl assificati on Array f or Outpati ent Encoun ter"RTN"," SDCO2",20, 0) ;            SDCLH DL  Classi fication E vent Handl e  [Option al]"RTN"," SDCO2",21, 0) ; Outpu t -- SDCOQ UIT User e ntered '^'  or timeou t"RTN","SD CO2",22,0)  N I,IOINH I,IOINORM, SDCTI,SDCT IS,SDCTS,S DEVTF,X"RT N","SDCO2" ,23,0) S X ="IOINHI;I OINORM" D  ENDR^%ZISS "RTN","SDC O2",24,0)  I '$D(SDCL OEY) G ASK Q"RTN","SD CO2",25,0)  W !!,"---  ",IOINHI, "Classific ation",IOI NORM," ---  [",IOINHI ,"Required ",IOINORM, "]""RTN"," SDCO2",26, 0) I '$G(S DCLHDL) N  SDATA,SDCL HDL S SDEV TF=1 D EVT ^SDCOU1(SD OE,"BEFORE ",.SDCLHDL ,.SDATA)"R TN","SDCO2 ",27,0) W  ! S SDCTIS =$$SEQ^SDC O21"RTN"," SDCO2",28, 0) F SDCTS =1:1 S SDC TI=+$P(SDC TIS,",",SD CTS) Q:'SD CTI!($D(SD COQUIT))   D"RTN","SD CO2",29,0)  .I $D(SDC LOEY(SDCTI )) D"RTN", "SDCO2",30 ,0) ..D ON E^SDCO20(S DCTI,SDCLO EY(SDCTI), SDOE,.SDCO QUIT)"RTN" ,"SDCO2",3 1,0) ..I S DCTI=3 F I =1,2,4,9 D  SC^SDCO21 (I,SDOE,"" ,.SDCLOEY)      ; SD* 5.3*631"RT N","SDCO2" ,32,0) I $ G(SDEVTF)  D EVT^SDCO U1(SDOE,"A FTER",SDCL HDL,.SDATA )"RTN","SD CO2",33,0) ASKQ Q"RTN ","SDCO2", 34,0) ;"RT N","SDCO2" ,35,0)CLAS K(SDOE,SDC LOEY) ;Ask  Classific ations on  Check Out" RTN","SDCO 2",36,0) ;  Input  --  SDOE      Outpatient  Encounter  file IEN" RTN","SDCO 2",37,0) ;  Output --  SDCLOEY   Classifica tion Array  for Outpa tient Enco unter"RTN" ,"SDCO2",3 8,0) ;                      Subs cripted by  Class Typ e file IEN "RTN","SDC O2",39,0)  ;                      Null or 4 09.42 IEN^ Internal V alue^1=n/a "RTN","SDC O2",40,0)  N SDOE0,SD ORG"RTN"," SDCO2",41, 0) S SDOE0 =$G(^SCE(+ SDOE,0)),S DORG=+$P(S DOE0,"^",8 )"RTN","SD CO2",42,0)  I $$REQ^S DM1A(+SDOE 0)'="CO" G  CLASKQ"RT N","SDCO2" ,43,0) I S DORG=1,'$$ CLINIC^SDA MU(+$P(SDO E0,"^",4))  G CLASKQ" RTN","SDCO 2",44,0) I  "^1^2^"[( "^"_SDORG_ "^"),$$INP ^SDAM2(+$P (SDOE0,"^" ,2),+SDOE0 )="I" G CL ASKQ"RTN", "SDCO2",45 ,0) I $$EX OE^SDCOU2( SDOE) G CL ASKQ"RTN", "SDCO2",46 ,0) D CLOE ^SDCO21(SD OE,.SDCLOE Y)"RTN","S DCO2",47,0 )CLASKQ Q" RTN","SDCO 21")0^25^B 6653603"RT N","SDCO21 ",1,0)SDCO 21 ;ALB/RM O - Classi fication C ont. - Che ck Out;30  MAR 1993 2 :10 pm ; 3 /12/04 4:3 3pm"RTN"," SDCO21",2, 0) ;;5.3;S cheduling; **150,244, 325,441,63 1**;Aug 13 , 1993;Bui ld 57"RTN" ,"SDCO21", 3,0) ;"RTN ","SDCO21" ,4,0)CL(DF N,SDDT,SDO E,SDCLY) ; Build Clas sification  Array"RTN ","SDCO21" ,5,0) ; In put  -- DF N      Pat ient file  IEN  "RTN" ,"SDCO21", 6,0) ;            SDD T     Date /Time"RTN" ,"SDCO21", 7,0) ;            SDO E     Outp atient Enc ounter fil e IEN  [Op tional]"RT N","SDCO21 ",8,0) ; O utput -- S DCLY    Cl assificati on Array"R TN","SDCO2 1",9,0) ;                      S ubscripted  by Class.  Type file  (#409.41)  IEN"RTN", "SDCO21",1 0,0) N SDC TI"RTN","S DCO21",11, 0) S SDCTI =0 F  S SD CTI=$O(^SD (409.41,SD CTI)) Q:'S DCTI  I $$ SCR(SDCTI, DFN,SDDT,$ G(SDOE)) S  SDCLY(SDC TI)="""RTN ","SDCO21" ,12,0)CLQ  Q"RTN","SD CO21",13,0 ) ;"RTN"," SDCO21",14 ,0)SCR(SDC TI,DFN,SDD T,SDOE) ;O utpatient  Classifica tion Type  Screen"RTN ","SDCO21" ,15,0) ; I nput  -- S DCTI    Ou tpatient C lassificat ion Type I EN"RTN","S DCO21",16, 0) ;            DFN       Patien t file IEN   "RTN","S DCO21",17, 0) ;            SDDT      Date/T ime"RTN"," SDCO21",18 ,0) ;            SDOE      Outpa tient Enco unter file  IEN  [Opt ional]"RTN ","SDCO21" ,19,0) ; O utput -- 1 =Yes and 0 =No"RTN"," SDCO21",20 ,0) N Y"RT N","SDCO21 ",21,0) I  $$ACT^SDCO DD(SDCTI,S DDT) D"RTN ","SDCO21" ,22,0) .I  $D(^SD(409 .41,SDCTI, 1)) X ^(1)  Q:'$T"RTN ","SDCO21" ,23,0) .S  Y=1"RTN"," SDCO21",24 ,0)SCRQ Q  +$G(Y)"RTN ","SDCO21" ,25,0) ;"R TN","SDCO2 1",26,0)CL OE(SDOE,SD CLOEY) ;Se t-up Class ification  Array for  Outpatient  Encounter "RTN","SDC O21",27,0)  ; Input   -- SDOE      Outpatie nt Encount er file IE N"RTN","SD CO21",28,0 ) ; Output  -- SDCLOE Y  Classif ication Ar ray Set fo r Outpatie nt Encount er"RTN","S DCO21",29, 0) ;                      Subscr ipted by C lass Type  file IEN"R TN","SDCO2 1",30,0) ;                       Null or 40 9.42 IEN^I nternal Va lue^1=n/a^ 1=unedt"RT N","SDCO21 ",31,0) N  SDCLY,SDCN 0,SDCNI,SD CTI,SDCTIS ,SDCTS,SDO E0"RTN","S DCO21",32, 0) S SDOE0 =$G(^SCE(+ SDOE,0))"R TN","SDCO2 1",33,0) D  CL($P(SDO E0,"^",2), +SDOE0,SDO E,.SDCLY)" RTN","SDCO 21",34,0)  S SDCTI=0  F  S SDCTI =$O(^SDD(4 09.42,"AO" ,SDOE,SDCT I)) Q:'SDC TI  S SDCN I=+$O(^(SD CTI,0)) I  $D(^SDD(40 9.42,SDCNI ,0)) S SDC N0=^(0) D" RTN","SDCO 21",35,0)  .S SDCLY(S DCTI)=SDCN I_"^"_$P(S DCN0,"^",3 )_"^"_$S(' $D(SDCLY(S DCTI)):1,1 :"")_"^"_$ S($P(SDOE0 ,"^",10)=2 :1,1:"")"R TN","SDCO2 1",36,0) S  SDCTIS=$$ SEQ"RTN"," SDCO21",37 ,0) F SDCT S=1:1 S SD CTI=+$P(SD CTIS,",",S DCTS) Q:'S DCTI  I $D (SDCLY(SDC TI)) S SDC LOEY(SDCTI )=SDCLY(SD CTI)"RTN", "SDCO21",3 8,0)CLOEQ  Q"RTN","SD CO21",39,0 ) ;"RTN"," SDCO21",40 ,0)SC(SDCT I,SDOE,SDS ELY,SDCLOE Y) ;Servic e Connecte d Classifi cation Che cks"RTN"," SDCO21",41 ,0) N SDCH GF,SDCLOE, SDSEL"RTN" ,"SDCO21", 42,0) S SD SEL=$S(SDC TI=1:2,SDC TI=2:3,SDC TI=4:4,SDC TI=9:9,1:" ") G SCQ:S DSEL=""      ;SD*5.3* 631"RTN"," SDCO21",43 ,0) D CHK( SDOE,SDCTI ,.SDCLOE)" RTN","SDCO 21",44,0)  I $D(SDCLO E) D  G SC Q"RTN","SD CO21",45,0 ) .I SDCLO E,$P(SDCLO E,"^",3) S  SDCHGF=1" RTN","SDCO 21",46,0)  .I SDCLOE= "" S SDCHG F=1"RTN"," SDCO21",47 ,0) .I $G( SDCHGF) S: $D(SDSELY)  SDSELY(SD SEL)="" S  SDCLOEY(SD CTI)=SDCLO E"RTN","SD CO21",48,0 ) I '$D(SD CLOE) D"RT N","SDCO21 ",49,0) .K  SDCLOEY(S DCTI)"RTN" ,"SDCO21", 50,0)SCQ Q "RTN","SDC O21",51,0)  ;"RTN","S DCO21",52, 0)CHK(SDOE ,SDCTI,SDC LOE) ;Chec k One Clas sification  for Outpa tient Enco unter"RTN" ,"SDCO21", 53,0) ; In put  -- SD OE     Out patient En counter fi le IEN"RTN ","SDCO21" ,54,0) ;            S DCTI    Ou tpatient C lassificat ion Type I EN"RTN","S DCO21",55, 0) ; Outpu t -- SDCLO E   Null o r 409.42 I EN^Interna l Value^1= n/a^1=uned t"RTN","SD CO21",56,0 ) N DFN,SD CL,SDCNI,S DDT,SDOE0" RTN","SDCO 21",57,0)  S SDOE0=$G (^SCE(+SDO E,0))"RTN" ,"SDCO21", 58,0) S DF N=+$P(SDOE 0,"^",2),S DDT=+SDOE0 "RTN","SDC O21",59,0)  I $$SCR(S DCTI,DFN,S DDT,SDOE)  S SDCL=""" RTN","SDCO 21",60,0)  S SDCNI=+$ O(^SDD(409 .42,"AO",S DOE,SDCTI, 0))"RTN"," SDCO21",61 ,0) I $D(^ SDD(409.42 ,SDCNI,0))  S SDCL=SD CNI_"^"_$P (^(0),"^", 3)_"^"_$S( '$D(SDCL): 1,1:"")_"^ "_$S($P(SD OE0,"^",10 )=2:1,1:"" )"RTN","SD CO21",62,0 ) I $D(SDC L) S SDCLO E=SDCL"RTN ","SDCO21" ,63,0)CHKQ  Q"RTN","S DCO21",64, 0) ;"RTN", "SDCO21",6 5,0)SEQ()  ;Classific ation Type  Sequence  by IEN"RTN ","SDCO21" ,66,0) ; I nput  -- N one"RTN"," SDCO21",67 ,0) ; Outp ut -- Clas sification  Type Sequ ence by IE N"RTN","SD CO21",68,0 ) ;            Curren t Sequence  is:  SC,  CV, AO, IR , EC, SHAD , MST, HNC , CLV"RTN" ,"SDCO21", 69,0) Q "3 ,7,1,2,4,8 ,5,6,9"        ; SD*5 .3*631  "R TN","SDCO2 2")0^26^B1 3353144"RT N","SDCO22 ",1,0)SDCO 22 ;ALB/RM O/MRY/ - C lassificat ion Cont.  - Screen -  Check Out ;9 MAY 200 5  11:15 P M ; 8/30/0 1 11:19am" RTN","SDCO 22",2,0) ; ;5.3;Sched uling;**15 0,222,244, 325,394,44 1,544,631* *;Aug 13,  1993;Build  57"RTN"," SDCO22",3, 0) ;"RTN", "SDCO22",4 ,0)AO(DFN, SDOE) ;Ask  Agent Ora nge Exposu re Classif ication"RT N","SDCO22 ",5,0) ; I nput  -- D FN      Pa tient file  IEN  "RTN ","SDCO22" ,6,0) ;            SD OE     Out patient En counter fi le IEN  [O ptional]"R TN","SDCO2 2",7,0) ;  Output --  1=Yes and  0=No"RTN", "SDCO22",8 ,0) N SDEL G0,Y"RTN", "SDCO22",9 ,0) I $P($ G(^DPT(DFN ,.321)),"^ ",2)="Y",$ P($G(^DPT( DFN,.321)) ,"^",13)=" V" D  ;SD/ 441"RTN"," SDCO22",10 ,0) . S SD ELG0=$$EL( DFN,$G(SDO E))"RTN"," SDCO22",11 ,0) . I $P (SDELG0,"^ ",5)="Y"," ^1^2^3^4^5 ^"[("^"_$P (SDELG0,"^ ",4)_"^")  S Y=1"RTN" ,"SDCO22", 12,0) . I  $G(Y),$G(S DOE) D"RTN ","SDCO22" ,13,0) . .  I '$$AP(S DOE,1) S Y =0 Q"RTN", "SDCO22",1 4,0) . . I  $P(SDELG0 ,"^",4)=3! ($P(SDELG0 ,"^",4)=1) ,$P($G(^SD D(409.42,+ $O(^SDD(40 9.42,"AO", +SDOE,3,0) ),0)),"^", 3) S Y=0"R TN","SDCO2 2",15,0)AO Q Q +$G(Y) "RTN","SDC O22",16,0)  ;"RTN","S DCO22",17, 0)IR(DFN,S DOE) ;Ask  Ionizing R adiation E xposure Cl assificati on"RTN","S DCO22",18, 0) ; Input   -- DFN       Patien t file IEN   "RTN","S DCO22",19, 0) ;            SDOE      Outpat ient Encou nter file  IEN  [Opti onal]"RTN" ,"SDCO22", 20,0) ; Ou tput -- 1= Yes and 0= No"RTN","S DCO22",21, 0) N SDELG 0,Y"RTN"," SDCO22",22 ,0) I $P($ G(^DPT(DFN ,.321)),"^ ",3)'="Y"  G IRQ"RTN" ,"SDCO22", 23,0) S SD ELG0=$$EL( DFN,$G(SDO E))"RTN"," SDCO22",24 ,0) I $P(S DELG0,"^", 5)="Y","^1 ^2^3^4^5^" [("^"_$P(S DELG0,"^", 4)_"^") S  Y=1"RTN"," SDCO22",25 ,0) I $G(Y ),$G(SDOE)  D"RTN","S DCO22",26, 0) .I '$$A P(SDOE,2)  S Y=0 Q"RT N","SDCO22 ",27,0) .I  $P(SDELG0 ,"^",4)=3! ($P(SDELG0 ,"^",4)=1) ,$P($G(^SD D(409.42,+ $O(^SDD(40 9.42,"AO", +SDOE,3,0) ),0)),"^", 3) S Y=0"R TN","SDCO2 2",28,0)IR Q Q +$G(Y) "RTN","SDC O22",29,0)  ;"RTN","S DCO22",30, 0)SC(DFN,S DOE) ;Ask  Service Co nnected Co ndition Cl assificati on"RTN","S DCO22",31, 0) ; Input   -- DFN       Patien t file IEN   "RTN","S DCO22",32, 0) ;            SDOE      Outpat ient Encou nter file  IEN  [Opti onal]"RTN" ,"SDCO22", 33,0) ; Ou tput -- 1= Yes and 0= No"RTN","S DCO22",34, 0) N SDELG 0,Y"RTN"," SDCO22",35 ,0) S SDEL G0=$$EL(DF N,$G(SDOE) )"RTN","SD CO22",36,0 ) I $P(SDE LG0,"^",5) ="Y","^1^3 ^"[("^"_$P (SDELG0,"^ ",4)_"^")  S Y=1"RTN" ,"SDCO22", 37,0) I $G (Y),$G(SDO E) D"RTN", "SDCO22",3 8,0) .I '$ $AP(SDOE,3 ) S Y=0 Q" RTN","SDCO 22",39,0)S CQ Q +$G(Y )"RTN","SD CO22",40,0 ) ;"RTN"," SDCO22",41 ,0)EC(DFN, SDOE) ;Ask  Environme ntal Conta minant Exp osure Clas sification "RTN","SDC O22",42,0)  ;sd/441 -  renamed ' SW Asia Co nditions'" RTN","SDCO 22",43,0)  ; Input  - - DFN       Patient f ile IEN  " RTN","SDCO 22",44,0)  ;            SDOE      Outpatien t Encounte r file IEN   [Optiona l]"RTN","S DCO22",45, 0) ; Outpu t -- 1=Yes  and 0=No" RTN","SDCO 22",46,0)  N SDELG0,Y "RTN","SDC O22",47,0)  S SDELG0= $$EL(DFN,$ G(SDOE))"R TN","SDCO2 2",48,0) I  $P($G(^DP T(DFN,.322 )),"^",13) '="Y" D  G  ECQ"RTN", "SDCO22",4 9,0) .I $P (SDELG0,"^ ",5)="N"," ^4^"[("^"_ $P(SDELG0, "^",4)_"^" ),"^A^B^C^ D^6^"[("^" _($P($G(^D IC(21,+$P( $G(^DPT(DF N,.32)),"^ ",3),0))," ^",3))_"^" ) S Y=1"RT N","SDCO22 ",50,0) I  $P(SDELG0, "^",5)="Y" ,"^1^2^3^4 ^5^"[("^"_ $P(SDELG0, "^",4)_"^" ) S Y=1"RT N","SDCO22 ",51,0) I  $G(Y),$G(S DOE) D"RTN ","SDCO22" ,52,0) .I  '$$AP(SDOE ,4) S Y=0  Q"RTN","SD CO22",53,0 ) .I $P(SD ELG0,"^",4 )=3!($P(SD ELG0,"^",4 )=1),$P($G (^SDD(409. 42,+$O(^SD D(409.42," AO",+SDOE, 3,0)),0)), "^",3) S Y =0"RTN","S DCO22",54, 0)ECQ Q +$ G(Y)"RTN", "SDCO22",5 5,0) ;"RTN ","SDCO22" ,56,0)EL(D FN,SDOE) ; Eligibilit y"RTN","SD CO22",57,0 ) Q $G(^DI C(8.1,+$P( $G(^DIC(8, +$S($P($G( ^SCE(+$G(S DOE),0))," ^",13):+$P (^(0),"^", 13),1:+$G( ^DPT(DFN,. 36))),0)), "^",9),0)) "RTN","SDC O22",58,0)  ;"RTN","S DCO22",59, 0)AP(SDOE, SDCTI) ;Cl assificati on Appoint ment Type  Screen"RTN ","SDCO22" ,60,0) N S DAPTY,Y,SD VSTIEN"RTN ","SDCO22" ,61,0) S S DAPTY=+$P( $G(^SCE(+S DOE,0)),"^ ",10)"RTN" ,"SDCO22", 62,0) I SD APTY=9 S Y =1"RTN","S DCO22",63, 0) I SDAPT Y=11 S Y=1 "RTN","SDC O22",64,0)  I SDAPTY= 2,SDCTI=3  S Y=1"RTN" ,"SDCO22", 65,0) S SD VSTIEN=$P( $G(^SCE(+S DOE,0)),U, 5)"RTN","S DCO22",66, 0) I $P($G (^AUPNVSIT (+SDVSTIEN ,812)),U,3 ) D"RTN"," SDCO22",67 ,0) .I $D( ^PX(839.7, "B","QUASA R",$P($G(^ AUPNVSIT(+ SDVSTIEN,8 12)),U,3)) ) D"RTN"," SDCO22",68 ,0) ..I $P ($G(^AUPNV SIT(+SDVST IEN,800)), U)'="" S Y =1"RTN","S DCO22",69, 0)APQ Q +$ G(Y)"RTN", "SDCO22",7 0,0) ;"RTN ","SDCO22" ,71,0)MST( DFN,SDOE)  ;Ask Milit ary Sexual  Trauma Cl assificati on"RTN","S DCO22",72, 0) ;Input  - DFN  Pat ient file  IEN"RTN"," SDCO22",73 ,0) ;         SDOE  O utpatient  Encounter  file IEN"R TN","SDCO2 2",74,0) ; Output - 1 =Yes, 0=No "RTN","SDC O22",75,0)  N DGMST"R TN","SDCO2 2",76,0) S  DGMST=$$G ETSTAT^DGM STAPI(DFN) "RTN","SDC O22",77,0)  Q +($P(DG MST,U,2)=" Y")"RTN"," SDCO22",78 ,0) ;"RTN" ,"SDCO22", 79,0)HNC(D FN,SDOE) ; Ask Head &  Neck Clas sification "RTN","SDC O22",80,0)  ;Input -  DFN  Patie nt file IE N"RTN","SD CO22",81,0 ) ;         SDOE  Out patient En counter fi le IEN"RTN ","SDCO22" ,82,0) ;Ou tput - 1=Y es, 0=No"R TN","SDCO2 2",83,0) N  DGARR,SDE LG0,Y"RTN" ,"SDCO22", 84,0) S SD ELG0=$$GET CUR^DGNTAP I(DFN,"DGA RR")"RTN", "SDCO22",8 5,0) S SDE LG0=+$G(DG ARR("STAT" ))"RTN","S DCO22",86, 0) ;Only a  status of  3, 4 or 5  is accept ed for the  question  to be aske d"RTN","SD CO22",87,0 ) S Y=$S(( ".3.4.5."[ ("."_SDELG 0_".")):1, 1:0)"RTN", "SDCO22",8 8,0)HNCQ Q  +$G(Y)"RT N","SDCO22 ",89,0) ;" RTN","SDCO 22",90,0)C V(DFN,SDOE ,SDDT) ;As k Combat V eteran Cla ssificatio n"RTN","SD CO22",91,0 ) ;Input :  DFN - Poi nter to PA TIENT file  (#2)"RTN" ,"SDCO22", 92,0) ;         SDOE  - Pointer  to OUTPATI ENT ENCOUN TER file ( #409.68)"R TN","SDCO2 2",93,0) ;         SD DT - Date  (FileMan f ormat) (op tional - S DOE overri des)"RTN", "SDCO22",9 4,0) ;Outp ut: 1 = Ye s / 0 = No "RTN","SDC O22",95,0)  N SDCV"RT N","SDCO22 ",96,0) S  SDDT=$G(SD DT)"RTN"," SDCO22",97 ,0) S:$G(S DOE) SDDT= +$G(^SCE(+ $G(SDOE),0 ))"RTN","S DCO22",98, 0) S:'SDDT  SDDT=$$DT ^XLFDT()"R TN","SDCO2 2",99,0) S  SDCV=$$CV EDT^DGCV(D FN,SDDT)"R TN","SDCO2 2",100,0)  Q $P(SDCV, "^",3)"RTN ","SDCO22" ,101,0) ;" RTN","SDCO 22",102,0) SHAD(DFN)  ;Ask Proje ct 112/SHA D Classifi cation"RTN ","SDCO22" ,103,0) ;I nput : DFN  - Pointer  to PATIEN T file (#2 )"RTN","SD CO22",104, 0) ;Output : 1 = Yes  / 0 = No /  "" = unan swered"RTN ","SDCO22" ,105,0) Q  $$GETSHAD^ DGUTL3(DFN )"RTN","SD CO22",106, 0) ;"RTN", "SDCO22",1 07,0)CLV(D FN,SDOE) ;  Ask Camp  Lejeune Cl assificati on"RTN","S DCO22",108 ,0) ; Inpu t  -- DFN       Patie nt file IE N"RTN","SD CO22",109, 0) ;            SDOE      Outpat ient Encou nter file  IEN  [Opti onal]"RTN" ,"SDCO22", 110,0) ; O utput -- 1 =Yes and 0 =No"RTN"," SDCO22",11 1,0) N SDE LG0,Y"RTN" ,"SDCO22", 112,0) I $ P($G(^DPT( DFN,.3217) ),"^")="Y"  D                ; S D*5.3*631" RTN","SDCO 22",113,0)  . S SDELG 0=$$EL(DFN ,$G(SDOE)) "RTN","SDC O22",114,0 ) . I $P(S DELG0,"^", 5)="Y","^1 ^2^3^4^5^" [("^"_$P(S DELG0,"^", 4)_"^") S  Y=1"RTN"," SDCO22",11 5,0) . I $ G(Y),$G(SD OE) D"RTN" ,"SDCO22", 116,0) . .  I '$$AP(S DOE,1) S Y =0 Q"RTN", "SDCO22",1 17,0) . .  I $P(SDELG 0,"^",4)=3 !($P(SDELG 0,"^",4)=1 ),$P($G(^S DD(409.42, +$O(^SDD(4 09.42,"AO" ,+SDOE,3,0 )),0)),"^" ,3) S Y=0" RTN","SDCO 22",118,0) CLVQ Q +$G (Y)"RTN"," SDCO22",11 9,0) ;"RTN ","SDPCE") 0^19^B4215 0048"RTN", "SDPCE",1, 0)SDPCE ;M JK/ALB/ -  Process PC E Event Da ta ;31 MAY  2005"RTN" ,"SDPCE",2 ,0) ;;5.3; Scheduling ;**27,91,1 32,150,244 ,325,441,6 31**;Aug 1 3, 1993;Bu ild 57"RTN ","SDPCE", 3,0) ;"RTN ","SDPCE", 4,0) ; *** * See SDPC E0 for var iable defi nitions ** **"RTN","S DPCE",5,0)  ;"RTN","S DPCE",6,0) EN ; -- ma in entry p t for PCE  event proc essing"RTN ","SDPCE", 7,0) ;"RTN ","SDPCE", 8,0) ; --  start rt m onitor"RTN ","SDPCE", 9,0) D:$D( XRTL) T0^% ZOSV"RTN", "SDPCE",10 ,0) ;"RTN" ,"SDPCE",1 1,0) N SDV SIT,SDVSIT 0,SDEVENT, SDERR,SDCL ST,SDCS,SD PCNT,SDVDT ,SDELAP"RT N","SDPCE" ,12,0) S S DVSIT0=0,S DEVENT="SD EVENT""RTN ","SDPCE", 13,0) ; --  process e ach visit  (initially  will only  be 1)"RTN ","SDPCE", 14,0) F  S  SDVSIT0=$ O(^TMP("PX KCO",$J,SD VSIT0)) Q: 'SDVSIT0   D"RTN","SD PCE",15,0)  . I $$HIS TORIC^VSIT (SDVSIT0)  Q"RTN","SD PCE",16,0)  . S SDVSI T("AFTER") =$G(^TMP(" PXKCO",$J, SDVSIT0,"V ST",SDVSIT 0,0,"AFTER ")),SDVSIT ("BEFORE") =$G(^("BEF ORE"))"RTN ","SDPCE", 17,0) .;"R TN","SDPCE ",18,0) .;  -- new or  old visit  "RTN","SD PCE",19,0)  . IF SDVS IT("AFTER" )]"",SDVSI T("BEFORE" )]""!(SDVS IT("BEFORE ")="") D A DD(.SDVSIT 0,.SDEVENT ,.SDERR) Q "RTN","SDP CE",20,0)  .;"RTN","S DPCE",21,0 ) .; -- de leted visi t"RTN","SD PCE",22,0)  . IF SDVS IT("AFTER" )="",SDVSI T("BEFORE" )]"" D DEL (.SDVSIT0, .SDEVENT,. SDERR) Q"R TN","SDPCE ",23,0) ;" RTN","SDPC E",24,0) ;  -- stop r t monitor" RTN","SDPC E",25,0) I F $D(XRT0)  S XRTN=$T (+0) D T1^ %ZOSV"RTN" ,"SDPCE",2 6,0) ;"RTN ","SDPCE", 27,0) Q"RT N","SDPCE" ,28,0) ;"R TN","SDPCE ",29,0)ADD (SDVSIT0,S DEVENT,SDE RR) ; -- a dd/update  encounter  data"RTN", "SDPCE",30 ,0) N DFN, SDT,SDCL,S DRESULT,SD TYPE,SDOE, SDDIS,SDPV SIT,SDELAP "RTN","SDP CE",31,0)  ; -- get p atient/enc ounter dat a"RTN","SD PCE",32,0)  D PAT(SDV SIT("AFTER "),.DFN,.S DT,.SDCL)" RTN","SDPC E",33,0) S  SDVSIT=$S ($P(SDVSIT ("AFTER"), U,12):$P(S DVSIT("AFT ER"),U,12) ,1:SDVSIT0 )"RTN","SD PCE",34,0)  ; --  get  encounter  data"RTN" ,"SDPCE",3 5,0) S SDO E=$O(^SCE( "AVSIT",+S DVSIT,0)), SDDIS=$P($ G(^SCE(+SD OE,0)),U,8 )"RTN","SD PCE",36,0)  I 'SDDIS, $G(SDOEP)  S SDDIS=$P ($G(^SCE(+ SDOEP,0)), U,8)"RTN", "SDPCE",37 ,0) ;"RTN" ,"SDPCE",3 8,0) ; --  get elig f or visit"R TN","SDPCE ",39,0) S  @SDEVENT@( "ELIGIBILI TY")=$S($P (SDVSIT("A FTER"),U,2 1):$P(SDVS IT("AFTER" ),U,21),1: "")"RTN"," SDPCE",40, 0) ;"RTN", "SDPCE",41 ,0) ; -- g et appt ty pe"RTN","S DPCE",42,0 ) S SDELAP =$G(^TMP(" PXKCO",$J, SDVSIT0,"V ST",SDVSIT 0,"ELAP"," AFTER"))"R TN","SDPCE ",43,0) S  @SDEVENT@( "APPT TYPE ")=$S($P(S DELAP,U,3) :$P(SDELAP ,U,3),1:"" )"RTN","SD PCE",44,0)  ;"RTN","S DPCE",45,0 ) ; -- get  co d/t"RT N","SDPCE" ,46,0) S @ SDEVENT@(" DATE/TIME" )=$S($P(SD VSIT("AFTE R"),U,18): $P(SDVSIT( "AFTER"),U ,18),1:"") "RTN","SDP CE",47,0)  ;"RTN","SD PCE",48,0)  ; -- dete rmine the  type of ev ent"RTN"," SDPCE",49, 0) IF SDCL ,SDCL=+$G( ^DPT(DFN," S",SDT,0))  D"RTN","S DPCE",50,0 ) . S @SDE VENT@("EVE NT")="CHEC K-OUT""RTN ","SDPCE", 51,0) ;"RT N","SDPCE" ,52,0) ELS E  I SDDIS ,SDDIS=3 D "RTN","SDP CE",53,0)  . S @SDEVE NT@("EVENT ")="DISPOS ITION""RTN ","SDPCE", 54,0) ;"RT N","SDPCE" ,55,0) ELS E  D  Q:$$ DELAE()"RT N","SDPCE" ,56,0) . S  @SDEVENT@ ("EVENT")= "ADD/EDIT  CHECK-OUT" "RTN","SDP CE",57,0)  . I SDVSIT  S SDPVSIT =SDVSIT D  ENCEVENT^P XKENC(SDPV SIT)"RTN", "SDPCE",58 ,0) ;"RTN" ,"SDPCE",5 9,0) ; --  get user"R TN","SDPCE ",60,0) S  @SDEVENT@( "USER")=$S ($D(^VA(20 0,+$G(DUZ) ,0)):+DUZ, 1:.5)"RTN" ,"SDPCE",6 1,0) D CLA SS(.SDVSIT ,.SDEVENT) "RTN","SDP CE",62,0)  S @SDEVENT @("VISIT C HANGE FLAG S")=$$CHAN GE(.SDVSIT 0)"RTN","S DPCE",63,0 ) I $G(SDP VSIT),'$D( @SDEVENT@( "CLASSIFIC ATION")) D  CLASSAE(S DPVSIT,.SD EVENT)"RTN ","SDPCE", 64,0) ; --  call api" RTN","SDPC E",65,0) D  API(DFN,S DT,SDCL,.S DEVENT,.SD ERR,SDVSIT ,"ADDITION ")"RTN","S DPCE",66,0 ) K ^TMP(" PXKENC",$J )"RTN","SD PCE",67,0)  Q"RTN","S DPCE",68,0 ) ;"RTN"," SDPCE",69, 0)DEL(SDVS IT0,SDEVEN T,SDERR) ;  -- delete  co info w hen visit  delete"RTN ","SDPCE", 70,0) N DF N,SDT,SDCL "RTN","SDP CE",71,0)  S SDVSIT=$ S($P(SDVSI T("AFTER") ,U,12):$P( SDVSIT("AF TER"),U,12 ),1:SDVSIT 0)"RTN","S DPCE",72,0 ) D PAT(SD VSIT("BEFO RE"),.DFN, .SDT,.SDCL )"RTN","SD PCE",73,0)  S @SDEVEN T@("USER") =$S($P(SDV SIT("BEFOR E"),U,23): $P(SDVSIT( "BEFORE"), U,23),1:.5 )"RTN","SD PCE",74,0)  S @SDEVEN T@("EVENT" )="CHECK-O UT DELETE" "RTN","SDP CE",75,0)  D API(DFN, SDT,SDCL,. SDEVENT,.S DERR,SDVSI T,"DELETIO N")"RTN"," SDPCE",76, 0) Q"RTN", "SDPCE",77 ,0) ;"RTN" ,"SDPCE",7 8,0)DELAE( ) ; -- del ete standa lone encou nter if no  cpt, dx a nd provide rs"RTN","S DPCE",79,0 ) N SDDEL" RTN","SDPC E",80,0) S  SDDEL=0"R TN","SDPCE ",81,0) IF  '$D(^TMP( "PXKENC",$ J,SDVSIT," CPT")),'$D (^("POV")) ,'$D(^("PR V")) D"RTN ","SDPCE", 82,0)  . S  @SDEVENT@ ("USER")=$ S($P(SDVSI T("BEFORE" ),U,23):$P (SDVSIT("B EFORE"),U, 23),1:.5)" RTN","SDPC E",83,0)   . S @SDEVE NT@("EVENT ")="CHECK- OUT DELETE ""RTN","SD PCE",84,0)   . D API( DFN,SDT,SD CL,.SDEVEN T,.SDERR,S DVSIT,"DEL ETION")"RT N","SDPCE" ,85,0)  .  K ^TMP("PX KENC",$J)" RTN","SDPC E",86,0)   . S SDDEL= 1"RTN","SD PCE",87,0)  Q SDDEL"R TN","SDPCE ",88,0) ;" RTN","SDPC E",89,0)AP I(DFN,SDT, SDCL,SDEVE NT,SDERR,S DVSIT,SDAC T) ;"RTN", "SDPCE",90 ,0) N SDRE T,SDSOR"RT N","SDPCE" ,91,0) S S DRET=$$EN^ SDAPI(DFN, SDT,SDCL,. SDEVENT,.S DERR,SDVSI T)"RTN","S DPCE",92,0 ) ;"RTN"," SDPCE",93, 0) ; -- is  it ok to  send bulle tin if nee ded"RTN"," SDPCE",94, 0) S SDSOR =+$O(^TMP( "PXKCO",$J ,SDVSIT,"S OR",0))"RT N","SDPCE" ,95,0) IF  SDSOR,'$P( $G(^TMP("P XKCO",$J,S DVSIT,"SOR ",SDSOR,0, "AFTER")), U,9) D"RTN ","SDPCE", 96,0) . Q" RTN","SDPC E",97,0) E LSE  D"RTN ","SDPCE", 98,0) . D  BULL^SDPCE 2(DFN,SDT, SDCL,.SDEV ENT,.SDERR ,SDVSIT,SD ACT)"RTN", "SDPCE",99 ,0) Q"RTN" ,"SDPCE",1 00,0) ;"RT N","SDPCE" ,101,0)PAT (SDVSIT0,D FN,SDT,SDC L) ; -- re turn patie nt/encount er data fo r visit"RT N","SDPCE" ,102,0) S  DFN=+$P(SD VSIT0,U,5) ,SDT=+SDVS IT0,SDCL=+ $P(SDVSIT0 ,U,22)"RTN ","SDPCE", 103,0) Q"R TN","SDPCE ",104,0) ; "RTN","SDP CE",105,0) CLASS(SDVS IT,SDEVENT ) ; -- set -up classi fication d ata from v isit data" RTN","SDPC E",106,0)  N SD800A,S D800B,SDI, CLASS,SDA, SDB"RTN"," SDPCE",107 ,0) S SD80 0A=$G(^TMP ("PXKCO",$ J,SDVSIT," VST",SDVSI T,800,"AFT ER")),SD80 0B=$G(^("B EFORE"))"R TN","SDPCE ",108,0) ;  -- proces s each pie ce    ; Ad ded Camp L ejeune SD* 5.3*631"RT N","SDPCE" ,109,0) F  SDI=1:1:9  D"RTN","SD PCE",110,0 ) . S CLAS S=$P("SC^A O^IR^EC^MS T^HNC^CV^S HAD^CLV",U ,SDI),SDA= $P(SD800A, U,SDI),SDB =$P(SD800B ,U,SDI)     ; SD*5.3* 631"RTN"," SDPCE",111 ,0) .; --  changed or  same clas s data"RTN ","SDPCE", 112,0) . I F SDA]"",S DB]"" S @S DEVENT@("C LASSIFICAT ION",$S(SD A'=SDB:"CH ANGE",1:"A DD"),CLASS )=$$CLASSV AL(SDA) Q" RTN","SDPC E",113,0)  .; -- new  class data "RTN","SDP CE",114,0)  . IF SDA] "",SDB=""  S @SDEVENT @("CLASSIF ICATION"," ADD",CLASS )=$$CLASSV AL(SDA) Q" RTN","SDPC E",115,0)  .; -- dele ted class  data"RTN", "SDPCE",11 6,0) . IF  SDA="",SDB ]"" S @SDE VENT@("CLA SSIFICATIO N","DELETE ",CLASS)=" " Q"RTN"," SDPCE",117 ,0) Q"RTN" ,"SDPCE",1 18,0)CLASS VAL(Y) ; - - yes/no p rocessing" RTN","SDPC E",119,0)  Q $S(Y=1:" Y",Y=0:"N" ,1:"??")"R TN","SDPCE ",120,0) ; "RTN","SDP CE",121,0) CLASSAE(SD VSIT,SDEVE NT) ; -- s et-up clas sification  data from  visit dat a"RTN","SD PCE",122,0 ) N SD800A ,SD800B,SD I,CLASS,SD A,SDB"RTN" ,"SDPCE",1 23,0) S SD 800A=$G(^T MP("PXKENC ",$J,SDVSI T,"VST",SD VSIT,800," AFTER")),S D800B=$G(^ ("BEFORE") )"RTN","SD PCE",124,0 ) ; -- pro cess each  piece  ; A dded Camp  Lejeune    SD*5.2*631   "RTN","S DPCE",125, 0) F SDI=1 :1:9 D"RTN ","SDPCE", 126,0) . S  CLASS=$P( "SC^AO^IR^ EC^MST^HNC ^CV^SHAD^C LV",U,SDI) ,SDA=$P(SD 800A,U,SDI ),SDB=$P(S D800B,U,SD I)     ; S D*5.3*631" RTN","SDPC E",127,0)  .; -- chan ged or sam e class da ta"RTN","S DPCE",128, 0) . IF SD A]"",SDB]" " S @SDEVE NT@("CLASS IFICATION" ,$S(SDA'=S DB:"CHANGE ",1:"ADD") ,CLASS)=$$ CLASSVAL(S DA) Q"RTN" ,"SDPCE",1 29,0) .; - - new clas s data"RTN ","SDPCE", 130,0) . I F SDA]"",S DB="" S @S DEVENT@("C LASSIFICAT ION","ADD" ,CLASS)=$$ CLASSVAL(S DA) Q"RTN" ,"SDPCE",1 31,0) .; - - deleted  class data "RTN","SDP CE",132,0)  . IF SDA= "",SDB]""  S @SDEVENT @("CLASSIF ICATION"," DELETE",CL ASS)="" Q" RTN","SDPC E",133,0)  Q"RTN","SD PCE",134,0 ) ;"RTN"," SDPCE",135 ,0)ELAP(DF N,SC) ; --  This func tion will  return Eli g and Appt  Type data "RTN","SDP CE",136,0)  ;  INPUT:  DFN - Pat ient, SC -  Clinic IE N"RTN","SD PCE",137,0 ) ; OUTPUT : Elig ptr ^ Elig tex t^ Appt Pt r^ Appt Te xt"RTN","S DPCE",138, 0) ;"RTN", "SDPCE",13 9,0) N VAE L,VADM,X,Y ,SDAPTYP,S DATD,SDEMP ,SDDECOD,S DEC,SDAMBA E"RTN","SD PCE",140,0 ) S SDAMBA E=1"RTN"," SDPCE",141 ,0) ;-- ge t appt typ e"RTN","SD PCE",142,0 ) D TYPE^S DM4"RTN"," SDPCE",143 ,0) S SDEM P="""RTN", "SDPCE",14 4,0) ;-- g et elig if  more than  1"RTN","S DPCE",145, 0) I $O(VA EL(1,0))>0  S SDEMP=" " D ELIG^S DM4:"369"[ SDAPTYP S  SDEMP=$S(S DDECOD:SDD ECOD,1:SDE MP)"RTN"," SDPCE",146 ,0) I 'SDE MP S SDEMP =VAEL(1)"R TN","SDPCE ",147,0) ; "RTN","SDP CE",148,0)  Q +SDEMP_ U_$P($G(^D IC(8,+SDEM P,0)),U)_U _+SDAPTYP_ U_$P($G(^S D(409.1,+S DAPTYP,0)) ,U)"RTN"," SDPCE",149 ,0) ;"RTN" ,"SDPCE",1 50,0)NEW(D ATE) ;-- T his functi on will re turn 1 if  SD is turn ed on for" RTN","SDPC E",151,0)  ;   Visit  Tracking a nd optiona lly check  if the dat e is past" RTN","SDPC E",152,0)  ;   the cu t over dat e for the  new PCE in terface."R TN","SDPCE ",153,0) ;  INPUT : D ATE (Optio nal) Date  to check f or cut ove r."RTN","S DPCE",154, 0) ; OUTPU T: 1 Yes,  0 No"RTN", "SDPCE",15 5,0) N SDR ES,SDX,SDY "RTN","SDP CE",156,0)  I '$G(DAT E) S DATE= DT"RTN","S DPCE",157, 0) ;-- is  Scheduling  on ?"RTN" ,"SDPCE",1 58,0) S SD RES=0,SDY= $$PKGON^VS IT("SD")"R TN","SDPCE ",159,0) ; -- if date  is it pas s cut over ?"RTN","SD PCE",160,0 ) S SDX=1  I $G(DATE)  S SDX=$$S WITCHCK^PX API(DATE)" RTN","SDPC E",161,0)  ;-- And to gether"RTN ","SDPCE", 162,0) I S DX,SDY S S DRES=1"RTN ","SDPCE", 163,0) Q S DRES"RTN", "SDPCE",16 4,0) ;"RTN ","SDPCE", 165,0)STAT US(SDVSIT)  ; Return  status of  an encount er"RTN","S DPCE",166, 0) ;  Inpu t:  SDOE =  Visit Fil e IEN"RTN" ,"SDPCE",1 67,0) ; Ou tput:  Sta tus of the  encounter  Internal  IEN^Extern al Value"R TN","SDPCE ",168,0) ; "RTN","SDP CE",169,0)  N SDINT,S DEXT,SDOE" RTN","SDPC E",170,0)  S SDOE=$O( ^SCE("AVSI T",+SDVSIT ,0))"RTN", "SDPCE",17 1,0) S SDI NT=$P($G(^ SCE(+SDOE, 0)),U,12)" RTN","SDPC E",172,0)  S SDEXT=$P ($G(^SD(40 9.63,+SDIN T,0)),U)"R TN","SDPCE ",173,0)ST ATQ Q SDIN T_"^"_SDEX T"RTN","SD PCE",174,0 ) ;"RTN"," SDPCE",175 ,0)CHANGE( SDVST) ; - - set flag s for over all visit  change"RTN ","SDPCE", 176,0) N S DI,SDFLAGS "RTN","SDP CE",177,0)  ;"RTN","S DPCE",178, 0) ; -- in italize ch ange flags "RTN","SDP CE",179,0)  ; -- cpt  changed ^  provider d ata change d ^ dx cha nged"RTN", "SDPCE",18 0,0) S SDF LAGS="0^0^ 0""RTN","S DPCE",181, 0) ;"RTN", "SDPCE",18 2,0) ; --  set cpt ch ange flag" RTN","SDPC E",183,0)  S SDI=0"RT N","SDPCE" ,184,0) F   S SDI=$O( ^TMP("PXKC O",$J,SDVS T,"CPT",SD I)) Q:'SDI   IF $G(^T MP("PXKCO" ,$J,SDVST, "CPT",SDI, 0,"BEFORE" ))'=$G(^(" AFTER")) S  $P(SDFLAG S,U,1)=1"R TN","SDPCE ",185,0) ; "RTN","SDP CE",186,0)  ; -- set  provider c hange flag "RTN","SDP CE",187,0)  S SDI=0"R TN","SDPCE ",188,0) F   S SDI=$O (^TMP("PXK CO",$J,SDV ST,"PRV",S DI)) Q:'SD I  IF $G(^ TMP("PXKCO ",$J,SDVST ,"PRV",SDI ,0,"BEFORE "))'=$G(^( "AFTER"))  S $P(SDFLA GS,U,2)=1" RTN","SDPC E",189,0)  ;"RTN","SD PCE",190,0 ) ; -- set  dx change  flag"RTN" ,"SDPCE",1 91,0) S SD I=0"RTN"," SDPCE",192 ,0) F  S S DI=$O(^TMP ("PXKCO",$ J,SDVST,"P OV",SDI))  Q:'SDI  IF  $G(^TMP(" PXKCO",$J, SDVST,"POV ",SDI,0,"B EFORE"))'= $G(^("AFTE R")) S $P( SDFLAGS,U, 3)=1"RTN", "SDPCE",19 3,0) ;"RTN ","SDPCE", 194,0) Q S DFLAGS"RTN ","SDPCE", 195,0) ;"R TN","SDPPA T1")0^20^B 22865926"R TN","SDPPA T1",1,0)SD PPAT1 ;ALB /CAW-Patie nt Profile  (Generic  Patient In fo) Screen  1;5/4/92" RTN","SDPP AT1",2,0)  ;;5.3;Sche duling;**6 ,140,441,6 31**;Aug 1 3, 1993;Bu ild 57"RTN ","SDPPAT1 ",3,0) ;"R TN","SDPPA T1",4,0) ; "RTN","SDP PAT1",5,0) PDATA ; Pa tient Data "RTN","SDP PAT1",6,0)  N SD,SDEL IG,SDDIS,S DCNT,CNT,S DCT,SDCOPS "RTN","SDP PAT1",7,0)  F SD=0,.3 ,.11,.121, .122,.13,. 32,.321,.3 217,.35,.3 6,.52,"TYP E","VET" S  SD(SD)=$G (^DPT(DFN, SD))   ; S D*5.3.631" RTN","SDPP AT1",8,0)  I $D(^DPT( DFN,.372,0 )) S SDDIS =0 F  S SD DIS=$O(^DP T(DFN,.372 ,SDDIS)) Q :'SDDIS  D "RTN","SDP PAT1",9,0)  .S SDDIS( SDDIS)=$G( ^DPT(DFN,. 372,SDDIS, 0))"RTN"," SDPPAT1",1 0,0) .S SD DIS(SDDIS) =$P($G(^DI C(31,+$P(S DDIS(SDDIS ),U),0)),U )_" ("_$S( $P(SDDIS(S DDIS),U,3) :"SC-",1:" NSC-")_$P( SDDIS(SDDI S),U,2)_"% )""RTN","S DPPAT1",11 ,0) .S SDC NT(SDDIS)= $L($P(SDDI S(SDDIS),U ))+2"RTN", "SDPPAT1", 12,0) S SD ELIG=0 F   S SDELIG=$ O(^DPT(DFN ,"E",SDELI G)) Q:'SDE LIG  S:SDE LIG'=+SD(. 36) SDELIG (SDELIG)=$ G(^DPT(DFN ,"E",SDELI G,0))"RTN" ,"SDPPAT1" ,13,0) S S D("MT")=$$ LST^DGMTU( DFN) I 'SD ("MT") S S DCOPS=$$LS T^DGMTU(DF N,"",2)"RT N","SDPPAT 1",14,0) S  SDFSTCOL= 22,SDSECCO L=60"RTN", "SDPPAT1", 15,0)PTDOB  ; Date of  Birth and  Marital S tatus Info "RTN","SDP PAT1",16,0 ) ;"RTN"," SDPPAT1",1 7,0) S X=" ",X=$$SETS TR^VALM1(" Date of Bi rth:",X,7, 14)"RTN"," SDPPAT1",1 8,0) S X=$ $SETSTR^VA LM1($$FTIM E^VALM1($P (SD(0),U,3 )),X,SDFST COL,18)"RT N","SDPPAT 1",19,0) S  X=$$SETST R^VALM1("M arital Sta tus:",X,44 ,15)"RTN", "SDPPAT1", 20,0) S X= $$SETSTR^V ALM1($P($G (^DIC(11,+ $P(SD(0),U ,5),0)),U) ,X,SDSECCO L,20)"RTN" ,"SDPPAT1" ,21,0) D S ET(X)"RTN" ,"SDPPAT1" ,22,0)PTSE X ; Sex an d Religion s Pref. In fo"RTN","S DPPAT1",23 ,0) ;"RTN" ,"SDPPAT1" ,24,0) S X ="",X=$$SE TSTR^VALM1 ("Sex:",X, 17,4)"RTN" ,"SDPPAT1" ,25,0) S X =$$SETSTR^ VALM1($S($ P(SD(0),U, 2)="F":"FE MALE",$P(S D(0),U,2)= "M":"MALE" ,1:"UNKNOW N"),X,SDFS TCOL,18)"R TN","SDPPA T1",26,0)  S X=$$SETS TR^VALM1(" Religious  Pref.:",X, 43,16)"RTN ","SDPPAT1 ",27,0) S  X=$$SETSTR ^VALM1($P( $G(^DIC(13 ,+$P(SD(0) ,U,8),0)), U),X,SDSEC COL,20)"RT N","SDPPAT 1",28,0) D  SET(X)"RT N","SDPPAT 1",29,0)PT RACE ; SSN  and Occup ation Info "RTN","SDP PAT1",30,0 ) ;"RTN"," SDPPAT1",3 1,0) S X=" ",X=$$SETS TR^VALM1(" Patient ID :",X,10,11 )"RTN","SD PPAT1",32, 0) S X=$$S ETSTR^VALM 1(VA("PID" ),X,SDFSTC OL,20)"RTN ","SDPPAT1 ",33,0) S  X=$$SETSTR ^VALM1("Oc cupation:" ,X,48,11)" RTN","SDPP AT1",34,0)  S X=$$SET STR^VALM1( $P(SD(0),U ,7),X,SDSE CCOL,20)"R TN","SDPPA T1",35,0)  D SET(X)"R TN","SDPPA T1",36,0)P WHO ; Who  entered an d Place of  Birth"RTN ","SDPPAT1 ",37,0) ;" RTN","SDPP AT1",38,0)  S X="",X= $$SETSTR^V ALM1("Who  entered:", X,9,12)"RT N","SDPPAT 1",39,0) S  X=$$SETST R^VALM1($P ($G(^VA(20 0,+$P(SD(0 ),U,15),0) ),U),X,SDF STCOL,20)" RTN","SDPP AT1",40,0)  S X=$$SET STR^VALM1( "Place of  Birth:",X, 44,15)"RTN ","SDPPAT1 ",41,0) S  X=$$SETSTR ^VALM1(($P (SD(0),U,1 1)_$S($P(S D(0),U,12) :", ",1:"" )_$P($G(^D IC(5,+$P(S D(0),U,12) ,0)),U)),X ,SDSECCOL, 20)"RTN"," SDPPAT1",4 2,0) D SET (X)"RTN"," SDPPAT1",4 3,0)PWHEN  ; Date ent ered"RTN", "SDPPAT1", 44,0) S X= "",X=$$SET STR^VALM1( "Date ente red:",X,8, 13)"RTN"," SDPPAT1",4 5,0) S X=$ $SETSTR^VA LM1($S($P( SD(0),U,16 ):$TR($$FM TE^XLFDT($ P(SD(0),U, 16),"5DF") ," ","0"), 1:""),X,SD FSTCOL,20) "RTN","SDP PAT1",46,0 ) D SET(X) "RTN","SDP PAT1",47,0 )MT ; Curr ent Means  Test - if  applicable "RTN","SDP PAT1",48,0 ) ;"RTN"," SDPPAT1",4 9,0) S X=" " I SD("MT ")'="" D"R TN","SDPPA T1",50,0)  .S X=$$SET STR^VALM1( "Current M eans Test: ",X,2,19)" RTN","SDPP AT1",51,0)  .S X=$$SE TSTR^VALM1 ($P(SD("MT "),U,3),X, SDFSTCOL,3 0)"RTN","S DPPAT1",52 ,0) .S X=$ $SETSTR^VA LM1("Date  Means Test :",X,43,16 )"RTN","SD PPAT1",53, 0) .S X=$$ SETSTR^VAL M1($TR($$F MTE^XLFDT( $P(SD("MT" ),U,2),"5D F")," ","0 "),X,SDSEC COL,20)"RT N","SDPPAT 1",54,0) I  $D(SDCOPS ),+SDCOPS  D"RTN","SD PPAT1",55, 0) .S X=$$ SETSTR^VAL M1("Curren t Co-Pay T est:",X,1, 20)"RTN"," SDPPAT1",5 6,0) .S X= $$SETSTR^V ALM1($P(SD COPS,U,3), X,SDFSTCOL ,30)"RTN", "SDPPAT1", 57,0) .S X =$$SETSTR^ VALM1("Dat e Co-Pay T est:",X,42 ,17)"RTN", "SDPPAT1", 58,0) .S X =$$SETSTR^ VALM1($TR( $$FMTE^XLF DT($P(SDCO PS,U,2),"5 DF")," "," 0"),X,SDSE CCOL,20)"R TN","SDPPA T1",59,0)  D SET(X)"R TN","SDPPA T1",60,0)R EMARK ; Re mark"RTN", "SDPPAT1", 61,0) S X= "" I $P(SD (0),U,10)' ="" D"RTN" ,"SDPPAT1" ,62,0) .S  X=$$SETSTR ^VALM1("Re marks:",X, 13,8)"RTN" ,"SDPPAT1" ,63,0) .S  X=$$SETSTR ^VALM1($P( SD(0),U,10 ),X,SDFSTC OL,60)"RTN ","SDPPAT1 ",64,0) D  SET(X)"RTN ","SDPPAT1 ",65,0)PRI ME ; Prima ry Eligibi lity"RTN", "SDPPAT1", 66,0) ;"RT N","SDPPAT 1",67,0) S  X="",X=$$ SETSTR^VAL M1("Primar y Eligibil ity:",X,1, 20)"RTN"," SDPPAT1",6 8,0) S X=$ $SETSTR^VA LM1($$FELI G(SD(.36)) ,X,SDFSTCO L,30)"RTN" ,"SDPPAT1" ,69,0) D S ET(X)"RTN" ,"SDPPAT1" ,70,0)OTHE RE ; Other  Eligibili ties and D ate of Dea th"RTN","S DPPAT1",71 ,0) ;"RTN" ,"SDPPAT1" ,72,0) S X ="",X=$$SE TSTR^VALM1 ("Other El igibilitie s:",X,1,20 )"RTN","SD PPAT1",73, 0) I $P(SD (.35),U)'= "" S X=$$S ETSTR^VALM 1("Date of  Death:",X ,45,14),X= $$SETSTR^V ALM1($TR($ $FMTE^XLFD T($P(SD(.3 5),U),"5DF ")," ","0" ),X,SDSECC OL,20)"RTN ","SDPPAT1 ",74,0) D  SET(X)"RTN ","SDPPAT1 ",75,0)VET  ; List of  other eli gibilities  and VETER AN(Y/N)"RT N","SDPPAT 1",76,0) S  SDELIG=0  F  S SDELI G=$O(SDELI G(SDELIG))  Q:'SDELIG   S SDCT=$ G(SDCT)+1, ROU=$S(SDC T=1:"OTH1" ,SDCT=2:"O TH2",1:"OT HM") D @RO U I SDCT=5  S X="",X= $$SETSTR^V ALM1("(thi s patient  has more ' other elig ibilities  that are n ot listed) ",X,10,65)  D SET(X)  Q"RTN","SD PPAT1",77, 0) I '$D(S DCT) D"RTN ","SDPPAT1 ",78,0) .S  X="",X=$$ SETSTR^VAL M1("VETERA N(Y/N):",X ,46,13)"RT N","SDPPAT 1",79,0) . S X=$$SETS TR^VALM1($ S(SD("VET" )="N":"NO" ,SD("VET") ="Y":"YES" ,1:"UNKNOW N"),X,SDSE CCOL,7)"RT N","SDPPAT 1",80,0) . D SET(X)"R TN","SDPPA T1",81,0)  .S X="",X= $$SETSTR^V ALM1("Type :",X,54,5) "RTN","SDP PAT1",82,0 ) .S X=$$S ETSTR^VALM 1($P($G(^D G(391,+SD( "TYPE"),0) ),U),X,SDS ECCOL,20)" RTN","SDPP AT1",83,0)  .D SET(X) "RTN","SDP PAT1",84,0 ) F SD=SDL N:1:12 D S ET("")"RTN ","SDPPAT1 ",85,0) D  ^SDPPAT2"R TN","SDPPA T1",86,0)  S VALMCNT= SDLN"RTN", "SDPPAT1", 87,0) Q"RT N","SDPPAT 1",88,0)SE T(X) ; Set  in ^TMP g lobal for  display"RT N","SDPPAT 1",89,0) ; "RTN","SDP PAT1",90,0 ) S SDLN=$ G(SDLN)+1, ^TMP("SDPP ",$J,SDLN, 0)=X"RTN", "SDPPAT1", 91,0) Q"RT N","SDPPAT 1",92,0)OT H1 ; First  'Other' E ligibility ' and VETE RAN(Y/N)"R TN","SDPPA T1",93,0)  S X="",X=$ $SETSTR^VA LM1($$FELI G(SDELIG(S DELIG)),X, 10,30)"RTN ","SDPPAT1 ",94,0) S  X=$$SETSTR ^VALM1("VE TERAN(Y/N) :",X,46,13 )"RTN","SD PPAT1",95, 0) S X=$$S ETSTR^VALM 1($S(SD("V ET")="N":" NO",SD("VE T")="Y":"Y ES",1:"UNK NOWN"),X,S DSECCOL,7) "RTN","SDP PAT1",96,0 ) D SET(X) "RTN","SDP PAT1",97,0 ) Q"RTN"," SDPPAT1",9 8,0)OTH2 ;  Second 'O ther Eligi bility' an d TYPE"RTN ","SDPPAT1 ",99,0) S  X="",X=$$S ETSTR^VALM 1($$FELIG( SDELIG(SDE LIG)),X,10 ,30)"RTN", "SDPPAT1", 100,0) S X =$$SETSTR^ VALM1("Typ e:",X,53,5 )"RTN","SD PPAT1",101 ,0) S X=$$ SETSTR^VAL M1($P($G(^ DG(391,+SD ("TYPE"),0 )),U),X,SD SECCOL,20) "RTN","SDP PAT1",102, 0) D SET(X )"RTN","SD PPAT1",103 ,0) Q"RTN" ,"SDPPAT1" ,104,0)OTH M ; Rest o f 'Other E ligibiliti es'"RTN"," SDPPAT1",1 05,0) Q:SD CT>4"RTN", "SDPPAT1", 106,0) S X ="",X=$$SE TSTR^VALM1 ($$FELIG(S DELIG(SDEL IG)),X,10, 30)"RTN"," SDPPAT1",1 07,0) D SE T(X)"RTN", "SDPPAT1", 108,0) Q"R TN","SDPPA T1",109,0) FELIG(ELIG ) ;"RTN"," SDPPAT1",1 10,0) ;  i nput - poi nter to el igibility  file"RTN", "SDPPAT1", 111,0) ; o utput - na me of elig ibility"RT N","SDPPAT 1",112,0)  Q $P($G(^D IC(8,+ELIG ,0)),U)"RT N","SDPPAT 2")0^21^B3 3407191"RT N","SDPPAT 2",1,0)SDP PAT2 ;ALB/ CAW/-Patie nt Profile  (Generic  Patient In fo)-Screen  2;5/4/92" RTN","SDPP AT2",2,0)  ;;5.3;Sche duling;**6 ,113,244,4 41,631**;A ug 13, 199 3;Build 57 "RTN","SDP PAT2",3,0)  ;"RTN","S DPPAT2",4, 0) ;"RTN", "SDPPAT2", 5,0)ADDR ;  Address a nd Phone H eaders"RTN ","SDPPAT2 ",6,0) ;"R TN","SDPPA T2",7,0) S  X="",X=$$ SETSTR^VAL M1("**Addr ess**",X,1 3,11)"RTN" ,"SDPPAT2" ,8,0) S X= $$SETSTR^V ALM1("**Ph one**",X,5 2,9)"RTN", "SDPPAT2", 9,0) D SET ^SDPPAT1(X )"RTN","SD PPAT2",10, 0)LINE1 ;  Line 1 of  address"RT N","SDPPAT 2",11,0) ; "RTN","SDP PAT2",12,0 ) S X="",X =$$SETSTR^ VALM1($P(S D(.11),U), X,10,29)"R TN","SDPPA T2",13,0)  S X=$$SETS TR^VALM1(" Residence: ",X,48,10) "RTN","SDP PAT2",14,0 ) S X=$$SE TSTR^VALM1 ($P(SD(.13 ),U),X,SDS ECCOL,20)" RTN","SDPP AT2",15,0)  D SET^SDP PAT1(X)"RT N","SDPPAT 2",16,0)LI NE2 ; Line  2 of addr ess"RTN"," SDPPAT2",1 7,0) ;"RTN ","SDPPAT2 ",18,0) S  X="" I $P( SD(.11),U, 2)'="" D"R TN","SDPPA T2",19,0)  .S X=$$SET STR^VALM1( $P(SD(.11) ,U,2),X,10 ,29)"RTN", "SDPPAT2", 20,0) I $P (SD(.13),U ,2)'="" D" RTN","SDPP AT2",21,0)  .S X=$$SE TSTR^VALM1 ("Work:",X ,53,5)"RTN ","SDPPAT2 ",22,0) .S  X=$$SETST R^VALM1($P (SD(.13),U ,2),X,SDSE CCOL,20)"R TN","SDPPA T2",23,0)  D:X'="" SE T^SDPPAT1( X)"RTN","S DPPAT2",24 ,0)LINE3 ;  Line 3 of  address"R TN","SDPPA T2",25,0)  ;"RTN","SD PPAT2",26, 0) I $P(SD (.11),U,3) '="" D"RTN ","SDPPAT2 ",27,0) .S  X="",X=$$ SETSTR^VAL M1($P(SD(. 11),U,3),X ,10,29)"RT N","SDPPAT 2",28,0) . D SET^SDPP AT1(X)"RTN ","SDPPAT2 ",29,0)LIN E4 ; Line  4 of addre ss (City,  State, Zip )"RTN","SD PPAT2",30, 0) ;If for eign (post al code, c ity, provi nce)"RTN", "SDPPAT2", 31,0) ; re trieve cou ntry info  -- PERM co untry is p iece 10 of  .11"RTN", "SDPPAT2", 32,0) N FI LE,CNTRY,F ORIEN,FORE IGN"RTN"," SDPPAT2",3 3,0) S FIL E=779.004, FORIEN=$P( SD(.11),U, 10),CNTRY= $$GET1^DIQ (FILE,FORI EN_",",2), CNTRY=$$UP PER^VALM1( CNTRY),FOR EIGN=$$FOR IEN^DGADDU TL(FORIEN) "RTN","SDP PAT2",34,0 ) I 'FOREI GN D"RTN", "SDPPAT2", 35,0) .N S DZIP"RTN", "SDPPAT2", 36,0) .S X ="" I SD(. 11)'="" S  SDZIP=$P(S D(.11),U,1 2) S:$E(SD ZIP,6,9)'= "" SDZIP=$ E(SDZIP,1, 5)_"-"_$E( SDZIP,6,9)  D"RTN","S DPPAT2",37 ,0) ..S X= $$SETSTR^V ALM1(($P(S D(.11),U,4 )_", "_$P( $G(^DIC(5, +$P(SD(.11 ),U,5),0)) ,U,2)_" "_ SDZIP),X,1 0,40)"RTN" ,"SDPPAT2" ,38,0) ..S  X=$$SETST R^VALM1("C ounty:",X, 51,7)"RTN" ,"SDPPAT2" ,39,0) ..S  X=$$SETST R^VALM1($P ($G(^DIC(5 ,+$P(SD(.1 1),U,5),1, +$P(SD(.11 ),U,7),0)) ,U),X,SDSE CCOL,20)"R TN","SDPPA T2",40,0)  E  D"RTN", "SDPPAT2", 41,0) . S  X="",X=($$ SETSTR^VAL M1($P(SD(. 11),U,9)_"  "_$P(SD(. 11),U,4)_"  "_$P(SD(. 11),U,8),X ,10,45))"R TN","SDPPA T2",42,0)  D SET^SDPP AT1(X)"RTN ","SDPPAT2 ",43,0)LIN E5 ;Displa y Country" RTN","SDPP AT2",44,0)  S X="",X= $$SETSTR^V ALM1(CNTRY ,X,10,45)" RTN","SDPP AT2",45,0)  D SET^SDP PAT1(X)"RT N","SDPPAT 2",46,0)TA DDR ; Addr ess and Ph one Header s"RTN","SD PPAT2",47, 0) ;"RTN", "SDPPAT2", 48,0) S X= """RTN","S DPPAT2",49 ,0) I ($P( SD(.121),U ,7)&($P(SD (.121),U,8 )>DT))!($P (SD(.121), U,7)&('$P( SD(.121),U ,8))) D"RT N","SDPPAT 2",50,0) . S X=$$SETS TR^VALM1(" **Temp. Ad dress**",X ,9,17)"RTN ","SDPPAT2 ",51,0) .S  X=$$SETST R^VALM1("* *Temp. Pho ne**",X,48 ,15)"RTN", "SDPPAT2", 52,0) .D S ET^SDPPAT1 (X)"RTN"," SDPPAT2",5 3,0)TLINE1  .; Line 1  of addres s"RTN","SD PPAT2",54, 0) .S X="" ,X=$$SETST R^VALM1($P (SD(.121), U),X,10,29 )"RTN","SD PPAT2",55, 0) .S X=$$ SETSTR^VAL M1("Reside nce:",X,48 ,10)"RTN", "SDPPAT2", 56,0) .S X =$$SETSTR^ VALM1($P(S D(.121),U, 10),X,SDSE CCOL,20)"R TN","SDPPA T2",57,0)  .D SET^SDP PAT1(X)"RT N","SDPPAT 2",58,0)TL INE2 .; Li ne 2 of ad dress"RTN" ,"SDPPAT2" ,59,0) .I  $P(SD(.121 ),U,2)'=""  D"RTN","S DPPAT2",60 ,0) ..S X= "",X=$$SET STR^VALM1( $P(SD(.121 ),U,2),X,1 0,29)"RTN" ,"SDPPAT2" ,61,0) ..D  SET^SDPPA T1(X)"RTN" ,"SDPPAT2" ,62,0)TLIN E3 .; Line  3 of addr ess"RTN"," SDPPAT2",6 3,0) .I $P (SD(.121), U,3)'="" D "RTN","SDP PAT2",64,0 ) ..S X="" ,X=$$SETST R^VALM1($P (SD(.121), U,3),X,10, 29)"RTN"," SDPPAT2",6 5,0) ..D S ET^SDPPAT1 (X)"RTN"," SDPPAT2",6 6,0)TLINE4  .; Line 4  of addres s (City, S tate, Zip) "RTN","SDP PAT2",67,0 ) .;If for eign (post al code, c ity, provi nce)"RTN", "SDPPAT2", 68,0) .; r etrieve co untry info  -- TEMP c ountry is  piece 3 of  .122"RTN" ,"SDPPAT2" ,69,0) .N  FILE,CNTRY ,FORIEN,FO REIGN"RTN" ,"SDPPAT2" ,70,0) .S  FILE=779.0 04,FORIEN= $P(SD(.122 ),U,3),CNT RY=$$GET1^ DIQ(FILE,F ORIEN_",", 2),CNTRY=$ $UPPER^VAL M1(CNTRY), FOREIGN=$$ FORIEN^DGA DDUTL(FORI EN)"RTN"," SDPPAT2",7 1,0) .I 'F OREIGN D"R TN","SDPPA T2",72,0)  ..N SDZIP" RTN","SDPP AT2",73,0)  ..S X=""  I SD(.121) '="" S SDZ IP=$P(SD(. 121),U,12)  S:$E(SDZI P,6,9)'=""  SDZIP=$E( SDZIP,1,5) _"-"_$E(SD ZIP,6,9) D "RTN","SDP PAT2",74,0 ) ...S X=$ $SETSTR^VA LM1(($P(SD (.121),U,4 )_", "_$P( $G(^DIC(5, +$P(SD(.12 1),U,5),0) ),U,2)_" " _SDZIP),X, 10,40)"RTN ","SDPPAT2 ",75,0) .. .S X=$$SET STR^VALM1( "County:", X,51,7)"RT N","SDPPAT 2",76,0) . ..S X=$$SE TSTR^VALM1 ($P($G(^DI C(5,+$P(SD (.121),U,5 ),1,+$P(SD (.121),U,1 1),0)),U), X,SDSECCOL ,20)"RTN", "SDPPAT2", 77,0) .E   D"RTN","SD PPAT2",78, 0) ..S X=" ",X=($$SET STR^VALM1( $P(SD(.122 ),U,2)_" " _$P(SD(.12 1),U,4)_"  "_$P(SD(.1 22),U),X,1 0,45))"RTN ","SDPPAT2 ",79,0) .D  SET^SDPPA T1(X)"RTN" ,"SDPPAT2" ,80,0)TLIN E5 .;Displ ay Country "RTN","SDP PAT2",81,0 ) .S X="", X=$$SETSTR ^VALM1(CNT RY,X,10,45 )"RTN","SD PPAT2",82, 0) .D SET^ SDPPAT1(X) "RTN","SDP PAT2",83,0 ) D SET^SD PPAT1("")" RTN","SDPP AT2",84,0) RAD ; Radi ation Expo sure and P risoner of  War"RTN", "SDPPAT2", 85,0) ;"RT N","SDPPAT 2",86,0) S  X="",X=$$ SETSTR^VAL M1("Radiat ion Exposu re:",X,2,1 9)"RTN","S DPPAT2",87 ,0) S X=$$ SETSTR^VAL M1($S($P(S D(.321),U, 3)="N":"NO ",$P(SD(.3 21),U,3)=" Y":"YES",1 :"UNKNOWN" ),X,SDFSTC OL,7)"RTN" ,"SDPPAT2" ,88,0) S X =$$SETSTR^ VALM1("Pri soner of W ar:",X,43, 16)"RTN"," SDPPAT2",8 9,0) S X=$ $SETSTR^VA LM1($S($P( SD(.52),U, 5)="N":"NO ",$P(SD(.5 2),U,5)="Y ":"YES",1: "UNKNOWN") ,X,SDSECCO L,7)"RTN", "SDPPAT2", 90,0) D SE T^SDPPAT1( X)"RTN","S DPPAT2",91 ,0)AO ; Ag ent Orange  Exposure  and Vietna m Service" RTN","SDPP AT2",92,0)  ;"RTN","S DPPAT2",93 ,0) S X="" ,X=$$SETST R^VALM1("A gent Orang e Exp.:",X ,3,18)"RTN ","SDPPAT2 ",94,0) S  X=$$SETSTR ^VALM1($S( $P(SD(.321 ),U,2)="N" :"NO",$P(S D(.321),U, 2)="Y":"YE S",1:"UNKN OWN"),X,SD FSTCOL,7)" RTN","SDPP AT2",95,0)  S X=$$SET STR^VALM1( "Vietnam S ervice:",X ,43,16)"RT N","SDPPAT 2",96,0) S  X=$$SETST R^VALM1($S ($P(SD(.32 1),U)="N": "NO",$P(SD (.321),U)= "Y":"YES", 1:"UNKNOWN "),X,SDSEC COL,7)"RTN ","SDPPAT2 ",97,0) D  SET^SDPPAT 1(X)"RTN", "SDPPAT2", 98,0) ;"RT N","SDPPAT 2",99,0)NT R ; Nose a nd Throat  Radium Exp osure"RTN" ,"SDPPAT2" ,100,0) ;" RTN","SDPP AT2",101,0 ) K SDNTR" RTN","SDPP AT2",102,0 ) S X="",X =$$SETSTR^ VALM1("N/T  Radium:", X,10,11)"R TN","SDPPA T2",103,0)  ;get curr ent NTR by  using sup ported API  (DBIA #34 57)"RTN"," SDPPAT2",1 04,0) S X= $$SETSTR^V ALM1($S($$ GETCUR^DGN TAPI(DFN," SDNTR")>0: $G(SDNTR(" INTRP")),1 :"UNKNOWN" ),X,SDFSTC OL,45)"RTN ","SDPPAT2 ",105,0) K  SDNTR"RTN ","SDPPAT2 ",106,0) D  SET^SDPPA T1(X)"RTN" ,"SDPPAT2" ,107,0) ;" RTN","SDPP AT2",108,0 )CLV ; Cam p Lejeune                          ; SD*5.3 *631   "RT N","SDPPAT 2",109,0)  S X="",X=$ $SETSTR^VA LM1("Camp  Lejeune:", X,8,13)"RT N","SDPPAT 2",110,0)  S X=$$SETS TR^VALM1($ S($P(SD(.3 217),U,1)= "N":"NO",$ P(SD(.3217 ),U,1)="Y" :"YES",1:" UNKNOWN"), X,SDFSTCOL ,7)"RTN"," SDPPAT2",1 11,0) D SE T^SDPPAT1( X)"RTN","S DPPAT2",11 2,0) ;"RTN ","SDPPAT2 ",113,0)PO S ; Period  of Servic e"RTN","SD PPAT2",114 ,0) ;"RTN" ,"SDPPAT2" ,115,0) S  X="",X=$$S ETSTR^VALM 1("Period  of Service :",X,3,18) "RTN","SDP PAT2",116, 0) S X=$$S ETSTR^VALM 1($P($G(^D IC(21,+$P( SD(.32),U, 3),0)),U), X,SDFSTCOL ,30)"RTN", "SDPPAT2", 117,0) D S ET^SDPPAT1 (X)"RTN"," SDPPAT2",1 18,0)SC ;  Service Co nnected an d Percenta ge"RTN","S DPPAT2",11 9,0) ;"RTN ","SDPPAT2 ",120,0) S  X="",X=$$ SETSTR^VAL M1("Servic e Connecte d:",X,3,18 )"RTN","SD PPAT2",121 ,0) S X=$$ SETSTR^VAL M1($S($P(S D(.3),U)=" N":"NO",$P (SD(.3),U) ="Y":"YES" ,1:"UNKNOW N"),X,SDFS TCOL,7)"RT N","SDPPAT 2",122,0)  I $P(SD(.3 ),U)'="Y"  D SET^SDPP AT1(X),SDQ  Q"RTN","S DPPAT2",12 3,0) S X=$ $SETSTR^VA LM1("Perce ntage:",X, 48,11)"RTN ","SDPPAT2 ",124,0) S  X=$$SETST R^VALM1($P (SD(.3),U, 2)_"%",X,S DSECCOL,4) "RTN","SDP PAT2",125, 0) D SET^S DPPAT1(X)" RTN","SDPP AT2",126,0 )SDQ ; Fin al set of  page if no  service c onnection" RTN","SDPP AT2",127,0 ) ;"RTN"," SDPPAT2",1 28,0) F CN T=SDLN:1:2 5 D SET^SD PPAT1("")" RTN","SDPP AT2",129,0 ) Q:'$D(SD CNT)"RTN", "SDPPAT2", 130,0)DIS  ; Disabili ties"RTN", "SDPPAT2", 131,0) ;"R TN","SDPPA T2",132,0)  S X="",X= $$SETSTR^V ALM1("Rate d Disabili ties:",X,7 ,19)"RTN", "SDPPAT2", 133,0) D S ET^SDPPAT1 (X)"RTN"," SDPPAT2",1 34,0) S CN T=0 F  S C NT=$O(SDDI S(CNT)) Q: 'CNT!('$D( SDCNT(+CNT )))  D"RTN ","SDPPAT2 ",135,0) . I '$D(SDDI S(CNT+1))  D SET^SDPP AT1(SDDIS( CNT)) Q"RT N","SDPPAT 2",136,0)  .I $L(SDDI S(CNT))<80 ,(SDCNT(CN T+1)+$L(SD DIS(CNT))> 79) D SET^ SDPPAT1(SD DIS(CNT))  K SDDIS(CN T) Q"RTN", "SDPPAT2", 137,0) .I  SDLN=24&($ D(SDDIS(CN T))) D SET ^SDPPAT1(" ...this pa tient has  more 'disa bilities'  that are n ot listed" ) K SDCNT  Q"RTN","SD PPAT2",138 ,0) .S SDD IS(CNT+1)= SDDIS(CNT) _", "_$G(S DDIS(CNT+1 ))"RTN","S DPPAT2",13 9,0) K SDD IS"RTN","S DPPAT2",14 0,0) D SET ^SDPPAT1(" ")"RTN","S DPPAT2",14 1,0) Q"SEC ","^DD",40 9.92,409.9 2,6,8)@"SE C","^DD",4 09.92,409. 92,7,8)@"S EC","^DIC" ,409.41,40 9.41,0,"DD ")@"SEC"," ^DIC",409. 41,409.41, 0,"DEL")@" SEC","^DIC ",409.41,4 09.41,0,"L AYGO")@"SE C","^DIC", 409.41,409 .41,0,"RD" )d"SEC","^ DIC",409.4 1,409.41,0 ,"WR")@"SE C","^DIC", 409.76,409 .76,0,"DD" )@"SEC","^ DIC",409.7 6,409.76,0 ,"DEL")@"S EC","^DIC" ,409.76,40 9.76,0,"LA YGO")@"SEC ","^DIC",4 09.76,409. 76,0,"RD") d"SEC","^D IC",409.76 ,409.76,0, "WR")@"SEC ","^DIC",4 09.92,409. 92,0,"AUDI T")@"SEC", "^DIC",409 .92,409.92 ,0,"DD")@" SEC","^DIC ",409.92,4 09.92,0,"D EL")@"SEC" ,"^DIC",40 9.92,409.9 2,0,"LAYGO ")@"SEC"," ^DIC",409. 92,409.92, 0,"WR")@"V ER")8.0^22 .2"^DD",40 9.41,409.4 1,0)FIELD^ ^75^12"^DD ",409.41,4 09.41,0,"D DA")N"^DD" ,409.41,40 9.41,0,"DT ")3180112" ^DD",409.4 1,409.41,0 ,"IX","AID ",409.4175 ,.01)"^DD" ,409.41,40 9.41,0,"IX ","B",409. 41,.01)"^D D",409.41, 409.41,0," NM","OUTPA TIENT CLAS SIFICATION  TYPE")"^D D",409.41, 409.41,0," PT",409.42 ,.01)"^DD" ,409.41,40 9.41,0,"VR PK")SD"^DD ",409.41,4 09.41,.001 ,0)NUMBER^ NJ3,0I^^ ^ K:+X'=X!(X >100)!(X<1 )!(X?.E1". "1N.N) X"^ DD",409.41 ,409.41,.0 01,3)Type  a Number b etween 1 a nd 100, 0  Decimal Di gits"^DD", 409.41,409 .41,.001,2 1,0)^^2^2^ 2930316^^" ^DD",409.4 1,409.41,. 001,21,1,0 )Enter in  this field  the inter nal entry  number ass ociated wi th this"^D D",409.41, 409.41,.00 1,21,2,0)o utpatient  classifica tion type. "^DD",409. 41,409.41, .001,"DT") 2921228"^D D",409.41, 409.41,.01 ,0)NAME^RF I^^0;1^K:$ L(X)>30!(X ?.N)!($L(X )<3)!'(X'? 1P.E) X"^D D",409.41, 409.41,.01 ,1,0)^.1"^ DD",409.41 ,409.41,.0 1,1,1,0)40 9.41^B"^DD ",409.41,4 09.41,.01, 1,1,1)S ^S D(409.41," B",$E(X,1, 30),DA)="" "^DD",409. 41,409.41, .01,1,1,2) K ^SD(409. 41,"B",$E( X,1,30),DA )"^DD",409 .41,409.41 ,.01,1,1," %D",0)^^2^ 2^2930621^ "^DD",409. 41,409.41, .01,1,1,"% D",1,0)Thi s cross-re ference al lows look- up by outp atient cla ssificatio n"^DD",409 .41,409.41 ,.01,1,1," %D",2,0)ty pe name."^ DD",409.41 ,409.41,.0 1,3)NAME M UST BE 3-3 0 CHARACTE RS, NOT NU MERIC OR S TARTING WI TH PUNCTUA TION"^DD", 409.41,409 .41,.01,21 ,0)^^1^1^2 930316^^^" ^DD",409.4 1,409.41,. 01,21,1,0) Enter in t his field  the name o f the outp atient cla ssificatio n type."^D D",409.41, 409.41,.01 ,"DEL",1,0 )I 1 W !,* 7,"Deletio n of an ap pointment  classifica tion type  is not all owed.""^DD ",409.41,4 09.41,.01, "DT")30109 27"^DD",40 9.41,409.4 1,.02,0)PR OMPT^F^^0; 2^K:$L(X)> 60!($L(X)< 1) X"^DD", 409.41,409 .41,.02,3) Answer mus t be 1-60  characters  in length ."^DD",409 .41,409.41 ,.02,21,0) ^^4^4^2930 621^^^^"^D D",409.41, 409.41,.02 ,21,1,0)En ter in thi s field th e prompt t o be used  as when th is outpati ent"^DD",4 09.41,409. 41,.02,21, 2,0)classi fication i s asked.   If this fi eld is not  defined t he NAME fi eld"^DD",4 09.41,409. 41,.02,21, 3,0)will b e used.  F or example , this fie ld might c ontain the  following :  "^DD",4 09.41,409. 41,.02,21, 4,0)   Was  treatment  for an SC  condition "^DD",409. 41,409.41, .02,23,0)^ ^1^1^29306 21^^"^DD", 409.41,409 .41,.02,23 ,1,0)This  field in u sed as DIR ("A") when  prompting  for outpa tient clas sification ."^DD",409 .41,409.41 ,.02,"DT") 3010925"^D D",409.41, 409.41,.03 ,0)INPUT T YPE^RSI^F: FREE-TEXT; N:NUMERIC; S:SET;Y:YE S/NO;^0;3^ Q"^DD",409 .41,409.41 ,.03,21,0) ^^2^2^2930 621^^^^"^D D",409.41, 409.41,.03 ,21,1,0)En ter in thi s field th e input ty pe to be u sed when t his"^DD",4 09.41,409. 41,.03,21, 2,0)outpat ient class ification  is asked." ^DD",409.4 1,409.41,. 03,23,0)^^ 1^1^293062 1^^"^DD",4 09.41,409. 41,.03,23, 1,0)This f ield is us ed as DIR( 0) when pr ompting fo r outpatie nt classif ication."^ DD",409.41 ,409.41,.0 3,"DT")293 0721"^DD", 409.41,409 .41,.04,0) DEFAULT^FI ^^0;4^K:$L (X)>10!($L (X)<1) X"^ DD",409.41 ,409.41,.0 4,3)Answer  must be 1 -10 charac ters in le ngth."^DD" ,409.41,40 9.41,.04,2 1,0)^^5^5^ 2930621^^^ ^"^DD",409 .41,409.41 ,.04,21,1, 0)Enter in  this fiel d the defa ult to be  used when  this outpa tient"^DD" ,409.41,40 9.41,.04,2 1,2,0)clas sification  is asked. "^DD",409. 41,409.41, .04,21,3,0 ) "^DD",40 9.41,409.4 1,.04,21,4 ,0)For exa mple, this  field mig ht contain  the follo wing if th e input ty pe is"^DD" ,409.41,40 9.41,.04,2 1,5,0)YES/ NO:  NO"^D D",409.41, 409.41,.04 ,23,0)^^1^ 1^2930621^ ^"^DD",409 .41,409.41 ,.04,23,1, 0)This fie ld is used  as DIR("B ") when pr ompting fo r outpatie nt classif ication."^ DD",409.41 ,409.41,.0 4,"DT")301 0927"^DD", 409.41,409 .41,.05,0) REQUIRED^S I^1:YES;0: NO;^0;5^Q" ^DD",409.4 1,409.41,. 05,1,0)^.1 ^^0"^DD",4 09.41,409. 41,.05,21, 0)^^2^2^29 30621^^^"^ DD",409.41 ,409.41,.0 5,21,1,0)E nter in th is field w hether or  not a resp onse is re quired whe n this"^DD ",409.41,4 09.41,.05, 21,2,0)out patient cl assificati on is aske d."^DD",40 9.41,409.4 1,.05,"DT" )2930721"^ DD",409.41 ,409.41,.0 6,0)DISPLA Y NAME^F^^ 0;6^K:$L(X )>30!($L(X )<1) X"^DD ",409.41,4 09.41,.06, 3)Answer m ust be 1-3 0 characte rs in leng th."^DD",4 09.41,409. 41,.06,21, 0)^^1^1^29 30621^"^DD ",409.41,4 09.41,.06, 21,1,0)Ent er in this  field the  text to b e displaye d on the c heck out s creen."^DD ",409.41,4 09.41,.06, "DT")30109 25"^DD",40 9.41,409.4 1,.07,0)AB BREVATION^ FI^^0;7^K: $L(X)>4!($ L(X)<1) X" ^DD",409.4 1,409.41,. 07,3)Answe r must be  1-4 charac ters in le ngth."^DD" ,409.41,40 9.41,.07,2 1,0)^^2^2^ 2930621^"^ DD",409.41 ,409.41,.0 7,21,1,0)E nter in th is field t he abbrevi ation for  the outpat ient class ification" ^DD",409.4 1,409.41,. 07,21,2,0) type.  For  example,  AO for Age nt Orange  Exposure." ^DD",409.4 1,409.41,. 07,"DT")29 30721"^DD" ,409.41,40 9.41,1,0)S CREEN^K^^1 ;E1,245^K: $L(X)>245  X D:$D(X)  ^DIM"^DD", 409.41,409 .41,1,3)Th is is Stan dard MUMPS  code."^DD ",409.41,4 09.41,1,9) @"^DD",409 .41,409.41 ,1,21,0)^^ 3^3^299042 1^^^^"^DD" ,409.41,40 9.41,1,21, 1,0)Enter  in this fi eld MUMPS  code to be  used as a  screen to  determine "^DD",409. 41,409.41, 1,21,2,0)w hether or  not a pati ent should  be asked  this outpa tient clas sification "^DD",409. 41,409.41, 1,21,3,0)t ype."^DD", 409.41,409 .41,1,23,0 )^^5^5^299 0421^^^^"^ DD",409.41 ,409.41,1, 23,1,0)The  following  variables  are suppo rted throu gh the out patient"^D D",409.41, 409.41,1,2 3,2,0)clas sification  function  calls:"^DD ",409.41,4 09.41,1,23 ,3,0) "^DD ",409.41,4 09.41,1,23 ,4,0) DFN       - Pat ient file  IEN"^DD",4 09.41,409. 41,1,23,5, 0) SDOE      - Outpat ient Encou nter file  IEN  [Opti onal]"^DD" ,409.41,40 9.41,1,"DT ")3160208" ^DD",409.4 1,409.41,2 ,0)INPUT P ARAMETERS^ FI^^2;1^K: $L(X)>245! ($L(X)<1)  X"^DD",409 .41,409.41 ,2,3)Answe r must be  1-245 char acters in  length."^D D",409.41, 409.41,2,2 1,0)^^3^3^ 2930621^^^ ^"^DD",409 .41,409.41 ,2,21,1,0) Enter in t his field  the input  parameters  to be use d when thi s"^DD",409 .41,409.41 ,2,21,2,0) outpatient  classific ation is a sked.  For  example,  this field  might con tain"^DD", 409.41,409 .41,2,21,3 ,0)the fol lowing if  the input  type is a  SET:  1:MA RRIED;2:SI NGLE"^DD", 409.41,409 .41,2,23,0 )^^1^1^293 0621^"^DD" ,409.41,40 9.41,2,23, 1,0)This f ield is us ed as DIR( 0) when pr ompting fo r outpatie nt classif ication."^ DD",409.41 ,409.41,2, "DT")29307 21"^DD",40 9.41,409.4 1,50,0)DES CRIPTION^4 09.415^^D; 0"^DD",409 .41,409.41 ,50,21,0)^ .001^2^2^3 150608^^"^ DD",409.41 ,409.41,50 ,21,1,0)En ter in thi s field th e descript ion associ ated with  this outpa tient"^DD" ,409.41,40 9.41,50,21 ,2,0)class ification  type."^DD" ,409.41,40 9.41,75,0) EFFECTIVE  DATE^409.4 175DA^^E;0 "^DD",409. 41,409.41, 75,21,0)^^ 2^2^293031 6^^"^DD",4 09.41,409. 41,75,21,1 ,0)Enter i n this fie ld the eff ective dat e of the o utpatient" ^DD",409.4 1,409.41,7 5,21,2,0)c lassificat ion type." ^DD",409.4 1,409.415, 0)DESCRIPT ION SUB-FI ELD^^.01^1 "^DD",409. 41,409.415 ,0,"DT")29 30316"^DD" ,409.41,40 9.415,0,"N M","DESCRI PTION")"^D D",409.41, 409.415,0, "UP")409.4 1"^DD",409 .41,409.41 5,.01,0)DE SCRIPTION^ W^^0;1^Q"^ DD",409.41 ,409.415,. 01,"DT")29 30316"^DD" ,409.41,40 9.4175,0)E FFECTIVE D ATE SUB-FI ELD^^.02^2 "^DD",409. 41,409.417 5,0,"DT")2 921228"^DD ",409.41,4 09.4175,0, "IX","B",4 09.4175,.0 1)"^DD",40 9.41,409.4 175,0,"NM" ,"EFFECTIV E DATE")"^ DD",409.41 ,409.4175, 0,"UP")409 .41"^DD",4 09.41,409. 4175,.01,0 )EFFECTIVE  DATE^RD^^ 0;1^S %DT= "EX" D ^%D T S X=Y K: Y<1 X"^DD" ,409.41,40 9.4175,.01 ,1,0)^.1"^ DD",409.41 ,409.4175, .01,1,1,0) 409.4175^B "^DD",409. 41,409.417 5,.01,1,1, 1)S ^SD(40 9.41,DA(1) ,"E","B",$ E(X,1,30), DA)="""^DD ",409.41,4 09.4175,.0 1,1,1,2)K  ^SD(409.41 ,DA(1),"E" ,"B",$E(X, 1,30),DA)" ^DD",409.4 1,409.4175 ,.01,1,1," %D",0)^^1^ 1^2930621^ "^DD",409. 41,409.417 5,.01,1,1, "%D",1,0)T his cross- reference  allows loo k-up by ef fective da te."^DD",4 09.41,409. 4175,.01,1 ,2,0)409.4 1^AID^MUMP S"^DD",409 .41,409.41 75,.01,1,2 ,1)S ^SD(4 09.41,DA(1 ),"E","AID ",-X,DA)=" ""^DD",409 .41,409.41 75,.01,1,2 ,2)K ^SD(4 09.41,DA(1 ),"E","AID ",-X,DA)"^ DD",409.41 ,409.4175, .01,1,2,"% D",0)^^3^3 ^2930621^" ^DD",409.4 1,409.4175 ,.01,1,2," %D",1,0)Th is cross-r eference c an be used  to sort b y outpatie nt classif ication"^D D",409.41, 409.4175,. 01,1,2,"%D ",2,0)type  by invers e effectiv e date by  internal e ntry numbe r"^DD",409 .41,409.41 75,.01,1,2 ,"%D",3,0) of the eff ective dat e."^DD",40 9.41,409.4 175,.01,1, 2,"DT")292 1228"^DD", 409.41,409 .4175,.01, 3)Enter in  this fiel d the effe ctive date  of the ou tpatient c lassificat ion type." ^DD",409.4 1,409.4175 ,.01,21,0) ^^2^2^2930 316^^"^DD" ,409.41,40 9.4175,.01 ,21,1,0)En ter in thi s field th e effectiv e date of  the outpat ient"^DD", 409.41,409 .4175,.01, 21,2,0)cla ssificatio n type."^D D",409.41, 409.4175,. 01,"DT")29 21228"^DD" ,409.41,40 9.4175,.02 ,0)ACTIVE^ RS^1:YES;0 :NO;^0;2^Q "^DD",409. 41,409.417 5,.02,3)En ter in thi s field wh ether of n ot the eff ective dat e of the o utpatient  classifica tion is ac tive or no t."^DD",40 9.41,409.4 175,.02,21 ,0)^^2^2^2 930316^^"^ DD",409.41 ,409.4175, .02,21,1,0 )Enter in  this field  whether o r not the  effective  date of th e"^DD",409 .41,409.41 75,.02,21, 2,0)outpat ient class ification  is active  or not."^D D",409.41, 409.4175,. 02,"DT")29 21228"^DD" ,409.76,40 9.76,0)FIE LD^^41^6"^ DD",409.76 ,409.76,0, "DDA")N"^D D",409.76, 409.76,0," DT")318011 2"^DD",409 .76,409.76 ,0,"IX","B ",409.76,. 01)"^DD",4 09.76,409. 76,0,"IX", "D",409.76 ,11)"^DD", 409.76,409 .76,0,"NM" ,"TRANSMIT TED OUTPAT IENT ENCOU NTER ERROR  CODE")"^D D",409.76, 409.76,0," PT",409.75 ,.02)"^DD" ,409.76,40 9.76,0,"VR PK")SD"^DD ",409.76,4 09.76,.01, 0)ERROR CO DE^RF^^0;1 ^K:$L(X)>1 0!($L(X)<1 )!'(X'?1P. E) X"^DD", 409.76,409 .76,.01,.1 )Error Cod e"^DD",409 .76,409.76 ,.01,1,0)^ .1"^DD",40 9.76,409.7 6,.01,1,1, 0)409.76^B "^DD",409. 76,409.76, .01,1,1,1) S ^SD(409. 76,"B",$E( X,1,30),DA )="""^DD", 409.76,409 .76,.01,1, 1,2)K ^SD( 409.76,"B" ,$E(X,1,30 ),DA)"^DD" ,409.76,40 9.76,.01,3 )Enter an  error code  to use (1 -10 charac ters)"^DD" ,409.76,40 9.76,.01,2 1,0)^^2^2^ 2970623^^^ "^DD",409. 76,409.76, .01,21,1,0 )Error cod e denoting  why an en try in the  Transmitt ed Outpati ent Encoun ter"^DD",4 09.76,409. 76,.01,21, 2,0)file c ould not b e transmit ted or suc cessfully  processed. "^DD",409. 76,409.76, .01,23,0)^ ^1^1^29706 23^"^DD",4 09.76,409. 76,.01,23, 1,0) "^DD" ,409.76,40 9.76,.01," DT")296043 0"^DD",409 .76,409.76 ,.02,0)SOU RCE OF ERR OR^RS^N:NP CD;V:VISTA ;T:HL7 TRA NSMISSION; ^0;2^Q"^DD ",409.76,4 09.76,.02, 3)Enter th e source o f the erro r."^DD",40 9.76,409.7 6,.02,21,0 )^^1^1^297 0710^"^DD" ,409.76,40 9.76,.02,2 1,1,0)This  set of co des indica tes the so urce of th e error."^ DD",409.76 ,409.76,.0 2,"DT")297 0710"^DD", 409.76,409 .76,11,0)E RROR CODE  DESCRIPTIO N^F^^1;1^K :$L(X)>80! ($L(X)<1)  X"^DD",409 .76,409.76 ,11,.1)Err or Code De scription" ^DD",409.7 6,409.76,1 1,1,0)^.1^ ^-1"^DD",4 09.76,409. 76,11,1,2, 0)409.76^D "^DD",409. 76,409.76, 11,1,2,1)S  ^SD(409.7 6,"D",$E(X ,1,30),DA) ="""^DD",4 09.76,409. 76,11,1,2, 2)K ^SD(40 9.76,"D",$ E(X,1,30), DA)"^DD",4 09.76,409. 76,11,1,2, "%D",0)^^1 ^1^2971210 ^"^DD",409 .76,409.76 ,11,1,2,"% D",1,0)Thi s is used  to aid in  the lookup  of error  codes."^DD ",409.76,4 09.76,11,1 ,2,"DT")29 71210"^DD" ,409.76,40 9.76,11,3) Enter a de scription  of the err or code (1 -80 charac ters)"^DD" ,409.76,40 9.76,11,21 ,0)^^1^1^2 960524^^"^ DD",409.76 ,409.76,11 ,21,1,0)Fr ee text de scription  of the err or code."^ DD",409.76 ,409.76,11 ,"DT")2980 120"^DD",4 09.76,409. 76,21,0)CO RRECTIVE A CTION DESC RIPTION^40 9.7621^^2; 0"^DD",409 .76,409.76 ,21,21,0)^ ^3^3^29710 22^"^DD",4 09.76,409. 76,21,21,1 ,0)This fi eld descri bes the ac tions nece ssary to c orrect the  error."^D D",409.76, 409.76,21, 21,2,0)Thi s is the t ext which  would be v iewed by a  user when  using the  Incomplet e"^DD",409 .76,409.76 ,21,21,3,0 )Encounter  Managemen t Tools."^ DD",409.76 ,409.76,31 ,0)VALIDAT ION LOGIC^ K^^CHK;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM "^DD",409. 76,409.76, 31,3)Enter  routine e ntry point  to perfor m error va lidation"^ DD",409.76 ,409.76,31 ,9)@"^DD", 409.76,409 .76,31,21, 0)^^13^13^ 2971022^"^ DD",409.76 ,409.76,31 ,21,1,0)Th is field s hould not  be modifed  except as  directed. "^DD",409. 76,409.76, 31,21,2,0)  "^DD",409 .76,409.76 ,31,21,3,0 )This cont ains the l ogic that  needs to b e executed  in order  to validat e the"^DD" ,409.76,40 9.76,31,21 ,4,0)data.   If the d ata does n ot validat e correctl y the erro r code fro m this"^DD ",409.76,4 09.76,31,2 1,5,0)entr y will be  used.  The  function  call conta ined withi n this fie ld uses"^D D",409.76, 409.76,31, 21,6,0)the  following  variables :"^DD",409 .76,409.76 ,31,21,7,0 )    Input "^DD",409. 76,409.76, 31,21,8,0)        Dat a - The va lue being  validated. "^DD",409. 76,409.76, 31,21,9,0)  "^DD",409 .76,409.76 ,31,21,10, 0)    Retu rns"^DD",4 09.76,409. 76,31,21,1 1,0)        RES - Res ult of the  function  call"^DD", 409.76,409 .76,31,21, 12,0)               1  if entry  passed val idation"^D D",409.76, 409.76,31, 21,13,0)                0 if ent ry does no t pass val idation"^D D",409.76, 409.76,31, "DT")29706 05"^DD",40 9.76,409.7 6,41,0)COR RECTION LO GIC^K^^COR ;E1,245^K: $L(X)>245  X D:$D(X)  ^DIM"^DD", 409.76,409 .76,41,3)T his is the  code that  will need  to be exe cuted to c orrect thi s error."^ DD",409.76 ,409.76,41 ,9)@"^DD", 409.76,409 .76,41,21, 0)^^16^16^ 2971022^"^ DD",409.76 ,409.76,41 ,21,1,0)Th is field s hould not  be modifed  except as  directed. "^DD",409. 76,409.76, 41,21,2,0)  "^DD",409 .76,409.76 ,41,21,3,0 )This cont ains the l ogic that  needs to b e executed  in order  to allow t he"^DD",40 9.76,409.7 6,41,21,4, 0)user to  correct th e error.   The functi on call co ntained wi thin this  field"^DD" ,409.76,40 9.76,41,21 ,5,0)uses  the follow ing variab les:"^DD", 409.76,409 .76,41,21, 6,0)    Re turns"^DD" ,409.76,40 9.76,41,21 ,7,0)        RES - Re sult of th e function  call"^DD" ,409.76,40 9.76,41,21 ,8,0)              0  - if the c orrective  action was  not succe ssful"^DD" ,409.76,40 9.76,41,21 ,9,0)              1  - if the c orrective  action suc ceeded"^DD ",409.76,4 09.76,41,2 1,10,0) "^ DD",409.76 ,409.76,41 ,21,11,0)T his functi on call ma kes the as sumption t hat the ^T MP("SCENI  XMT",$J,0) "^DD",409. 76,409.76, 41,21,12,0 )global fr om the Inc omplete En counter Ma nagement L ist Manage r tool is" ^DD",409.7 6,409.76,4 1,21,13,0) available  to retriev e the poin ter from t he TRANSMI TTED OUTPA TIENT"^DD" ,409.76,40 9.76,41,21 ,14,0)ENCO UNTER FILE  (#409.73)  which is  used to ch eck the en try and"^D D",409.76, 409.76,41, 21,15,0)re treive the  entry fro m the TRAN SMITTED OU TPATIENT E NCOUNTER E RROR FILE" ^DD",409.7 6,409.76,4 1,21,16,0) (#409.75). "^DD",409. 76,409.76, 41,"DT")29 70710"^DD" ,409.76,40 9.7621,0)C ORRECTIVE  ACTION DES CRIPTION S UB-FIELD^^ .01^1"^DD" ,409.76,40 9.7621,0," DT")297071 0"^DD",409 .76,409.76 21,0,"NM", "CORRECTIV E ACTION D ESCRIPTION ")"^DD",40 9.76,409.7 621,0,"UP" )409.76"^D D",409.76, 409.7621,. 01,0)CORRE CTIVE ACTI ON DESCRIP TION^W^^0; 1^Q"^DD",4 09.76,409. 7621,.01,3 )Enter the  correctiv e action a  user will  need to t ake in ord er to corr ect this e rror."^DD" ,409.76,40 9.7621,.01 ,21,0)^^1^ 1^2971022^ ^^"^DD",40 9.76,409.7 621,.01,21 ,1,0)This  is the cor rective ac tion neede d to corre ct this er ror situat ion."^DD", 409.76,409 .7621,.01, "DT")29707 10"^DD",40 9.92,409.9 2,0)FIELD^ ^16^17"^DD ",409.92,4 09.92,0,"D DA")N"^DD" ,409.92,40 9.92,0,"DT ")3180112" ^DD",409.9 2,409.92,0 ,"ID",2)W  "   ",$P(^ (0),U,3)"^ DD",409.92 ,409.92,0, "ID",4)W "    ",$P(^( 0),U,5)"^D D",409.92, 409.92,0," IX","AC",4 09.92,16)" ^DD",409.9 2,409.92,0 ,"IX","B", 409.92,.01 )"^DD",409 .92,409.92 ,0,"IX","C ",409.92,4 )"^DD",409 .92,409.92 ,0,"NM","A CRP REPORT  TEMPLATE  PARAMETER" )"^DD",409 .92,409.92 ,0,"VRPK") SD"^DD",40 9.92,409.9 2,.01,0)OR DER NUMBER ^RF^^0;1^K :$L(X)>4!( $L(X)<4)!' (X?4N) X"^ DD",409.92 ,409.92,.0 1,1,0)^.1" ^DD",409.9 2,409.92,. 01,1,1,0)4 09.92^B"^D D",409.92, 409.92,.01 ,1,1,1)S ^ SD(409.92, "B",$E(X,1 ,30),DA)=" ""^DD",409 .92,409.92 ,.01,1,1,2 )K ^SD(409 .92,"B",$E (X,1,30),D A)"^DD",40 9.92,409.9 2,.01,3)An swer must  be 4 chara cters in l ength, all  numeric;  where the  first 2 ch aracters r epresent t he order o f the majo r category , the seco nd 2 chara cters repr esent the  order of t he minor c ategory."^ DD",409.92 ,409.92,.0 1,21,0)^^5 ^5^2980529 ^"^DD",409 .92,409.92 ,.01,21,1, 0)This is  a 4 digit  numeric va lue that d etermines  where (and  in what"^ DD",409.92 ,409.92,.0 1,21,2,0)o rder) each  data elem ent will b e displaye d by ^DIR  for select ion in the "^DD",409. 92,409.92, .01,21,3,0 )'ACRP Ad  Hoc Report '.  The fi rst to dig its determ ine the or der of the "^DD",409. 92,409.92, .01,21,4,0 )major cat egory of t his data e lement.  T he second  two digits  determine  the"^DD", 409.92,409 .92,.01,21 ,5,0)order  of the su bcategory  of this da ta element  (within t he major c ategory)." ^DD",409.9 2,409.92,. 01,"DT")29 80319"^DD" ,409.92,40 9.92,1,0)M AJOR CATEG ORY (INTER NAL)^F^^0; 2^K:$L(X)> 2!($L(X)<2 ) X"^DD",4 09.92,409. 92,1,3)Ans wer must b e 2 charac ters in le ngth."^DD" ,409.92,40 9.92,1,21, 0)^^4^4^29 80529^"^DD ",409.92,4 09.92,1,21 ,1,0)This  is the int ernal valu e or acron ym that re presents t he major c ategory"^D D",409.92, 409.92,1,2 1,2,0)of t his data e lement.  T he 4 chara cter acron ym created  by concat inating"^D D",409.92, 409.92,1,2 1,3,0)the  major cate gory acrom ym with th e subcateg ory acrony m is used  as a"^DD", 409.92,409 .92,1,21,4 ,0)unique  identifier  for this  data eleme nt."^DD",4 09.92,409. 92,1,"DT") 2980319"^D D",409.92, 409.92,2,0 )MAJOR CAT EGORY (EXT ERNAL)^F^^ 0;3^K:$L(X )>40!($L(X )<1) X"^DD ",409.92,4 09.92,2,3) Answer mus t be 1-40  characters  in length ."^DD",409 .92,409.92 ,2,21,0)^^ 2^2^298052 9^"^DD",40 9.92,409.9 2,2,21,1,0 )This is t he externa l represen tation of  the major  category ( conceptual "^DD",409. 92,409.92, 2,21,2,0)g roup) of t his data e lement."^D D",409.92, 409.92,2," DT")298040 8"^DD",409 .92,409.92 ,3,0)MINOR  CATEGORY  (INTERNAL) ^F^^0;4^K: $L(X)>2!($ L(X)<2) X" ^DD",409.9 2,409.92,3 ,3)Answer  must be 2  characters  in length ."^DD",409 .92,409.92 ,3,21,0)^^ 2^2^298052 9^"^DD",40 9.92,409.9 2,3,21,1,0 )This is t he interna l value or  acronym t hat repres ents the s ubcategory "^DD",409. 92,409.92, 3,21,2,0)o f this dat a element. "^DD",409. 92,409.92, 3,"DT")298 0319"^DD", 409.92,409 .92,4,0)MI NOR CATEGO RY (EXTERN AL)^F^^0;5 ^K:$L(X)>4 0!($L(X)<1 ) X"^DD",4 09.92,409. 92,4,1,0)^ .1"^DD",40 9.92,409.9 2,4,1,1,0) 409.92^C^M UMPS"^DD", 409.92,409 .92,4,1,1, 1)S ^SD(40 9.92,"C",X ,DA)="""^D D",409.92, 409.92,4,1 ,1,2)K ^SD (409.92,"C ",X,DA)"^D D",409.92, 409.92,4,1 ,1,"DT")29 80319"^DD" ,409.92,40 9.92,4,3)A nswer must  be 1-40 c haracters  in length. "^DD",409. 92,409.92, 4,21,0)^^2 ^2^2980529 ^"^DD",409 .92,409.92 ,4,21,1,0) This is th e external  represent ation of t he subcate gory (actu al data va lue)"^DD", 409.92,409 .92,4,21,2 ,0)of this  data elem ent."^DD", 409.92,409 .92,4,"DT" )2980408"^ DD",409.92 ,409.92,5, 0)TYPE^S^D :DATE;P:PO INTER;F:FI ELD;N:NUMB ER;T:TEXT; C:COMPUTED ;PP:POINTE R/POINTER; S:SET OF C ODES;^0;6^ Q"^DD",409 .92,409.92 ,5,3)Indic ates the t ype of dat a this ele ment is."^ DD",409.92 ,409.92,5, 21,0)^^2^2 ^2980529^" ^DD",409.9 2,409.92,5 ,21,1,0)Th is field d efines the  type of d ata this d ata elemen t consists  of and "^ DD",409.92 ,409.92,5, 21,2,0)det ermines ho w it will  be manipul ated gener ically."^D D",409.92, 409.92,5," DT")298031 9"^DD",409 .92,409.92 ,6,0)TYPE  WHERE^F^^7 ;E1,245^K: $L(X)>245! ($L(X)<1)  X"^DD",409 .92,409.92 ,6,3)Answe r must be  1-245 char acters in  length.  C ontains 'w here' (glo bal or fie ld) or exe cute code  that sets  up DIR arr ay for set  of codes. "^DD",409. 92,409.92, 6,8.5)@"^D D",409.92, 409.92,6,9 )@"^DD",40 9.92,409.9 2,6,21,0)^ ^9^9^29805 29^"^DD",4 09.92,409. 92,6,21,1, 0)This ind icates whe re or how  this data  type is fo und or cod e to set u p"^DD",409 .92,409.92 ,6,21,2,0) DIR(0). Sp ecifically :"^DD",409 .92,409.92 ,6,21,3,0)  "^DD",409 .92,409.92 ,6,21,4,0)        Dat a type:                Value:"^D D",409.92, 409.92,6,2 1,5,0)        ------- ---------- -      --- ---------- ---------- --------"^ DD",409.92 ,409.92,6, 21,6,0)        FIELD                     "f ile#,field #""^DD",40 9.92,409.9 2,6,21,7,0 )       PO INTER                   global r oot of fil e pointed  to"^DD",40 9.92,409.9 2,6,21,8,0 )       PO INTER/POIN TER          "globalr oot;field# ""^DD",409 .92,409.92 ,6,21,9,0)        SET  OF CODES              execute c ode to set  DIR(0)"^D D",409.92, 409.92,6," DT")298031 9"^DD",409 .92,409.92 ,7,0)TYPE  SCREEN^F^^ 8;E1,245^K :$L(X)>245 !($L(X)<1)  X"^DD",40 9.92,409.9 2,7,3)Answ er must be  1-245 cha racters in  length.   Value for  DIC("S") o r input tr ansform."^ DD",409.92 ,409.92,7, 8.5)@"^DD" ,409.92,40 9.92,7,9)@ "^DD",409. 92,409.92, 7,21,0)^^9 ^9^2980529 ^"^DD",409 .92,409.92 ,7,21,1,0) This field  contains  logic for  DIC("S") o r paramete rs for DIC (0),"^DD", 409.92,409 .92,7,21,2 ,0)specifi cally:"^DD ",409.92,4 09.92,7,21 ,3,0) "^DD ",409.92,4 09.92,7,21 ,4,0)        Data typ e:               Valu e:"^DD",40 9.92,409.9 2,7,21,5,0 )       -- ---------- --------     -------- ---------- ---------- ---------" ^DD",409.9 2,409.92,7 ,21,6,0)        DATE                      v alue for D IR(0)           (requ ired)"^DD" ,409.92,40 9.92,7,21, 7,0)        NUMBER                    value  for DIR(0 )           (required )"^DD",409 .92,409.92 ,7,21,8,0)        POI NTER                   screen lo gic for DI C("S") (op tional)"^D D",409.92, 409.92,7,2 1,9,0)        TEXT                      val ue for DIR (0)           (requir ed)"^DD",4 09.92,409. 92,7,"DT") 2980319"^D D",409.92, 409.92,8,0 )CHOICE ME THOD^S^L:L IST;R:RANG E;LR:LIST  OR RANGE;^ 0;9^Q"^DD" ,409.92,40 9.92,8,3)D etermines  selection  method(s)  allowed fo r this dat a element. "^DD",409. 92,409.92, 8,21,0)^^2 ^2^2980529 ^"^DD",409 .92,409.92 ,8,21,1,0) This deter mines the  choice met hod(s) the  user will  be allowe d when"^DD ",409.92,4 09.92,8,21 ,2,0)selec ting items  for this  data eleme nt."^DD",4 09.92,409. 92,8,"DT") 2980319"^D D",409.92, 409.92,9,0 )NUMBER OF  CHOICES^N J3,0^^0;10 ^K:+X'=X!( X>999)!(X< 0)!(X?.E1" ."1N.N) X" ^DD",409.9 2,409.92,9 ,3)Type a  Number bet ween 0 and  999, 0 De cimal Digi ts.  Limit s the numb er of choi ces for li st selecti on."^DD",4 09.92,409. 92,9,21,0) ^^2^2^2980 529^"^DD", 409.92,409 .92,9,21,1 ,0)This de termines t he maximum  number of  item choi ces a user  is allowe d"^DD",409 .92,409.92 ,9,21,2,0) for this d ata elemen t."^DD",40 9.92,409.9 2,9,"DT")2 980319"^DD ",409.92,4 09.92,10,0 )CODE TO S ET 'SDX'^K ^^11;E1,24 5^K:$L(X)> 245 X D:$D (X) ^DIM"^ DD",409.92 ,409.92,10 ,3)This is  Standard  MUMPS code .  Creates  SDX array  where SDX (internal  value)=ext ernal valu e."^DD",40 9.92,409.9 2,10,9)@"^ DD",409.92 ,409.92,10 ,21,0)^^6^ 6^2980529^ "^DD",409. 92,409.92, 10,21,1,0) When an en counter is  being eva luated, th e actual d ata values  for this  "^DD",409. 92,409.92, 10,21,2,0) data eleme nt are ext racted int o an array  where:"^D D",409.92, 409.92,10, 21,3,0) "^ DD",409.92 ,409.92,10 ,21,4,0)        SDX(n )=internal  value^ext ernal valu e"^DD",409 .92,409.92 ,10,21,5,0 ) "^DD",40 9.92,409.9 2,10,21,6, 0)This fie ld contain s code whi ch, when e xecuted, w ill create  the SDX a rray."^DD" ,409.92,40 9.92,10,"D T")2980319 "^DD",409. 92,409.92, 11,0)OUTPU T TRANSFOR M^K^^12;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M"^DD",409 .92,409.92 ,11,3)This  is Standa rd MUMPS c ode.  Perf orms outpu t transfor m (where S DX="intern al value^e xternal va lue" or "i nt;int^ext  / ext" fo r pointer/ pointer da ta types). "^DD",409. 92,409.92, 11,9)@"^DD ",409.92,4 09.92,11,2 1,0)^^2^2^ 2980529^"^ DD",409.92 ,409.92,11 ,21,1,0)Th is field c ontains co de which,  when execu ted, will  transform  the values "^DD",409. 92,409.92, 11,21,2,0) in the SDX (n) array  into a dif ferent for mat, if de sired."^DD ",409.92,4 09.92,11," DT")298031 9"^DD",409 .92,409.92 ,12,0)CODE  TO SET 'S DIRQ'^K^^1 3;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM"^DD" ,409.92,40 9.92,12,3) This is St andard MUM PS code.   Code that  sets SDIRQ  array for  use as DI R("?")."^D D",409.92, 409.92,12, 9)@"^DD",4 09.92,409. 92,12,21,0 )^^2^2^298 0529^"^DD" ,409.92,40 9.92,12,21 ,1,0)This  field cont ains code  that sets  the SDIRQ  array to h elp text u sed as"^DD ",409.92,4 09.92,12,2 1,2,0)the  DIR("?") a rray."^DD" ,409.92,40 9.92,12,"D T")2980319 "^DD",409. 92,409.92, 13,0)ADDIT IONAL LIMI TATIONS^F^ ^0;14^K:$L (X)>4!($L( X)<4) X"^D D",409.92, 409.92,13, 3)Answer m ust be 4 c haracters  in length.   Represen ts synonym ous additi onal limit ations to  apply when  evaluatin g limitati ons."^DD", 409.92,409 .92,13,21, 0)^^3^3^29 80529^"^DD ",409.92,4 09.92,13,2 1,1,0)This  field con tains the  acronym re presenting  an additi onal data  element"^D D",409.92, 409.92,13, 21,2,0)to  be applied  synonymou sly when e valuating  this data  element as  a "^DD",4 09.92,409. 92,13,21,3 ,0)limitat ion."^DD", 409.92,409 .92,13,"DT ")2980319" ^DD",409.9 2,409.92,1 4,0)PRINT  FIELD LEVE L^S^0:EXCL UDE;1:ENCO UNTER DETA IL ONLY;2: ALL DETAIL  TYPES;^0; 15^Q"^DD", 409.92,409 .92,14,3)D etermines  which data  element a re selecta ble for wh ich patien t detail t ypes (ie.  encounter  or patient /visit)."^ DD",409.92 ,409.92,14 ,21,0)^^2^ 2^2980529^ "^DD",409. 92,409.92, 14,21,1,0) This field  describes  what leve l of detai l this dat a element  is related "^DD",409. 92,409.92, 14,21,2,0) to and res tricts sel ection acc ordingly." ^DD",409.9 2,409.92,1 4,"DT")298 0319"^DD", 409.92,409 .92,15,0)M ULTIPLE VA LUED^S^0:N O;1:YES;^0 ;16^Q"^DD" ,409.92,40 9.92,15,3) Indicates  if this da ta element  is potent ially mult iply value d."^DD",40 9.92,409.9 2,15,21,0) ^^2^2^2980 529^"^DD", 409.92,409 .92,15,21, 1,0)This i ndicates i f the actu al data fo r this dat a element  can potent ially"^DD" ,409.92,40 9.92,15,21 ,2,0)be mu ltiply val ued."^DD", 409.92,409 .92,15,"DT ")2980319" ^DD",409.9 2,409.92,1 6,0)ACRONY M^F^^1;1^K :$L(X)>4!( $L(X)<4) X "^DD",409. 92,409.92, 16,1,0)^.1 "^DD",409. 92,409.92, 16,1,1,0)4 09.92^AC^M UMPS"^DD", 409.92,409 .92,16,1,1 ,1)S ^SD(4 09.92,"C", X,DA)="""^ DD",409.92 ,409.92,16 ,1,1,2)K ^ SD(409.92, "C",X,DA)" ^DD",409.9 2,409.92,1 6,1,1,"%D" ,0)^^1^1^2 980319^^^" ^DD",409.9 2,409.92,1 6,1,1,"%D" ,1,0)Adds  acronym to  'C' x-ref . for look up."^DD",4 09.92,409. 92,16,1,1, "DT")29803 19"^DD",40 9.92,409.9 2,16,3)Ans wer must b e 4 charac ters in le ngth."^DD" ,409.92,40 9.92,16,21 ,0)^^3^3^2 980529^"^D D",409.92, 409.92,16, 21,1,0)Thi s field co ntains the  acronym w hich uniqu ely identi fies this  data "^DD" ,409.92,40 9.92,16,21 ,2,0)eleme nt.  It is  a 4 chara cter value  which con sists of t he interna l"^DD",409 .92,409.92 ,16,21,3,0 )values of  the major  category  and subcat egory of t his data e lement."^D D",409.92, 409.92,16, "DT")29803 19"^DIC",4 09.41,409. 41,0)OUTPA TIENT CLAS SIFICATION  TYPE^409. 41"^DIC",4 09.41,409. 41,0,"GL") ^SD(409.41 ,"^DIC",40 9.41,409.4 1,"%D",0)^ ^7^7^29307 22^^^^"^DI C",409.41, 409.41,"%D ",1,0)This  table fil e contains  types of  outpatient  classific ations. "^ DIC",409.4 1,409.41," %D",2,0)Th ese includ e Service  Connected,  Agent Ora nge Exposu re, Ionizi ng"^DIC",4 09.41,409. 41,"%D",3, 0)Radiatio n Exposure , Camp Lej eune and E nvironment al Contami nants."^DI C",409.41, 409.41,"%D ",4,0) "^D IC",409.41 ,409.41,"% D",5,0)If  an entry n eeds to be  added, mo dified or  deleted a  patch will  be"^DIC", 409.41,409 .41,"%D",6 ,0)issued  instructin g the site  how to ma ke the cha nge.  Othe rwise,"^DI C",409.41, 409.41,"%D ",7,0)this  table sho uld not be  edited in  anyway by  the site. "^DIC",409 .41,"B","O UTPATIENT  CLASSIFICA TION TYPE" ,409.41)"^ DIC",409.7 6,409.76,0 )TRANSMITT ED OUTPATI ENT ENCOUN TER ERROR  CODE^409.7 6"^DIC",40 9.76,409.7 6,0,"GL")^ SD(409.76, "^DIC",409 .76,409.76 ,"%D",0)^^ 6^6^297062 3^^^^"^DIC ",409.76,4 09.76,"%D" ,1,0)This  table file  contains  a list of  all error  codes that  the Natio nal"^DIC", 409.76,409 .76,"%D",2 ,0)Patient  Care Data base will  report whe n processi ng an enco unter."^DI C",409.76, 409.76,"%D ",3,0) "^D IC",409.76 ,409.76,"% D",4,0)If  an entry n eeds to be  added, mo dified or  deleted a  patch will  be issued "^DIC",409 .76,409.76 ,"%D",5,0) instructin g the site  how to ma ke the cha nge.  Othe rwise, thi s table sh ould"^DIC" ,409.76,40 9.76,"%D", 6,0)not be  edited in  anyway by  the site.   "^DIC",4 09.76,"B", "TRANSMITT ED OUTPATI ENT ENCOUN T",409.76) "^DIC",409 .92,409.92 ,0)ACRP RE PORT TEMPL ATE PARAME TER^409.92 "^DIC",409 .92,409.92 ,0,"GL")^S D(409.92," ^DIC",409. 92,409.92, "%D",0)^^4 ^4^2980705 ^^^^"^DIC" ,409.92,40 9.92,"%D", 1,0)This f ile contai ns the par ameters ne cessary to  manipulat e the vari ous data"^ DIC",409.9 2,409.92," %D",2,0)el ements use d by the ' ACRP Ad Ho c Report'  [SCRPW AD  HOC REPORT ]."^DIC",4 09.92,409. 92,"%D",3, 0) "^DIC", 409.92,409 .92,"%D",4 ,0)          *** THE  CONTENTS O F THIS FIL E SHOULD N OT BE EDIT ED ***"^DI C",409.92, "B","ACRP  REPORT TEM PLATE PARA METER",409 .92)**END* ***END**
        2  
        3  
        4  
        5  
        6  
        7  
        8  
        9  
        10  
        11  
        12  
        13  

Araxis Merge (but not the data content of this report) is Copyright © 1993-2016 Araxis Ltd (www.araxis.com). All rights reserved.