KIDS Distribution saved on Jan 02, 2003@16:54:18 RACE AND ETHNICITY, 1997 STANDARDS (DG*5.3*415 / SD*5.3*254) **KIDS**:DG*5.3*415^SD*5.3*254^ **INSTALL NAME** DG*5.3*415 "BLD",3584,0) DG*5.3*415^REGISTRATION^0^3030102^y "BLD",3584,4,0) ^9.64PA^45.64^5 "BLD",3584,4,2,0) 2 "BLD",3584,4,2,2,0) ^9.641^2^3 "BLD",3584,4,2,2,2,0) PATIENT (File-top level) "BLD",3584,4,2,2,2,1,0) ^9.6411^.06^1 "BLD",3584,4,2,2,2,1,.06,0) RACE "BLD",3584,4,2,2,2.02,0) RACE INFORMATION (sub-file) "BLD",3584,4,2,2,2.02,1,0) ^9.6411^^ "BLD",3584,4,2,2,2.06,0) ETHNICITY INFORMATION (sub-file) "BLD",3584,4,2,2,2.06,1,0) ^9.6411^^ "BLD",3584,4,2,222) y^n^p^^^^n "BLD",3584,4,10,0) 10 "BLD",3584,4,10,222) y^n^f^^n^^n^o^n "BLD",3584,4,10.2,0) 10.2 "BLD",3584,4,10.2,222) y^y^f^^n^^y^o^n "BLD",3584,4,10.3,0) 10.3 "BLD",3584,4,10.3,222) y^y^f^^n^^y^o^n "BLD",3584,4,45.64,0) 45.64 "BLD",3584,4,45.64,222) n^n^f^^n^^y^o^n "BLD",3584,4,45.64,224) I $P(^(0),"^",1)=713 "BLD",3584,4,"APDD",2,2) "BLD",3584,4,"APDD",2,2,.06) "BLD",3584,4,"APDD",2,2.02) "BLD",3584,4,"APDD",2,2.06) "BLD",3584,4,"B",2,2) "BLD",3584,4,"B",10,10) "BLD",3584,4,"B",10.2,10.2) "BLD",3584,4,"B",10.3,10.3) "BLD",3584,4,"B",45.64,45.64) "BLD",3584,"INI") PRE^DG53415 "BLD",3584,"INIT") POST^DG53415 "BLD",3584,"KRN",0) ^9.67PA^8989.52^19 "BLD",3584,"KRN",.4,0) .4 "BLD",3584,"KRN",.401,0) .401 "BLD",3584,"KRN",.402,0) .402 "BLD",3584,"KRN",.402,"NM",0) ^9.68A^4^4 "BLD",3584,"KRN",.402,"NM",1,0) DG101 FILE #45^45^0 "BLD",3584,"KRN",.402,"NM",2,0) DG101F FILE #45^45^0 "BLD",3584,"KRN",.402,"NM",3,0) DGQWK FILE #45^45^0 "BLD",3584,"KRN",.402,"NM",4,0) DGQWKF FILE #45^45^0 "BLD",3584,"KRN",.402,"NM","B","DG101 FILE #45",1) "BLD",3584,"KRN",.402,"NM","B","DG101F FILE #45",2) "BLD",3584,"KRN",.402,"NM","B","DGQWK FILE #45",3) "BLD",3584,"KRN",.402,"NM","B","DGQWKF FILE #45",4) "BLD",3584,"KRN",.403,0) .403 "BLD",3584,"KRN",.5,0) .5 "BLD",3584,"KRN",.84,0) .84 "BLD",3584,"KRN",3.6,0) 3.6 "BLD",3584,"KRN",3.8,0) 3.8 "BLD",3584,"KRN",9.2,0) 9.2 "BLD",3584,"KRN",9.8,0) 9.8 "BLD",3584,"KRN",9.8,"NM",0) ^9.68A^28^28 "BLD",3584,"KRN",9.8,"NM",1,0) VAFHLPID^^0^B9502545 "BLD",3584,"KRN",9.8,"NM",2,0) VAFHLPI1^^0^B22032319 "BLD",3584,"KRN",9.8,"NM",3,0) VAFCPID^^0^B12182426 "BLD",3584,"KRN",9.8,"NM",4,0) VAFHLU^^0^B2213135 "BLD",3584,"KRN",9.8,"NM",5,0) VADPT^^0^B16792425 "BLD",3584,"KRN",9.8,"NM",6,0) VADPT0^^0^B10884518 "BLD",3584,"KRN",9.8,"NM",7,0) VADPT1^^0^B25184957 "BLD",3584,"KRN",9.8,"NM",8,0) DGRPE^^0^B34626804 "BLD",3584,"KRN",9.8,"NM",9,0) DGRPV^^0^B16180219 "BLD",3584,"KRN",9.8,"NM",10,0) DGRPU1^^0^B6015150 "BLD",3584,"KRN",9.8,"NM",11,0) DGPTF1^^0^B29748655 "BLD",3584,"KRN",9.8,"NM",12,0) DGPT701^^0^B13169396 "BLD",3584,"KRN",9.8,"NM",13,0) DGPT701P^^0^B2908139 "BLD",3584,"KRN",9.8,"NM",14,0) DGPTAE^^0^B14522606 "BLD",3584,"KRN",9.8,"NM",15,0) DGPT101^^0^B12471768 "BLD",3584,"KRN",9.8,"NM",16,0) DGPTAEE2^^0^B13919194 "BLD",3584,"KRN",9.8,"NM",17,0) DGPTFTR^^0^B18207491 "BLD",3584,"KRN",9.8,"NM",18,0) DGPTFVC1^^0^B34530107 "BLD",3584,"KRN",9.8,"NM",19,0) DGPTR1^^0^B24526056 "BLD",3584,"KRN",9.8,"NM",20,0) DGPTR4^^0^B14594444 "BLD",3584,"KRN",9.8,"NM",21,0) DGRP2^^0^B9120510 "BLD",3584,"KRN",9.8,"NM",22,0) DGRPH^^0^B27221934 "BLD",3584,"KRN",9.8,"NM",23,0) VAFHBGJ^^0^B4103720 "BLD",3584,"KRN",9.8,"NM",24,0) VAFHQRY^^0^B3246580 "BLD",3584,"KRN",9.8,"NM",25,0) VAFCA04^^0^B13594719 "BLD",3584,"KRN",9.8,"NM",26,0) VAFCADT2^^0^B18812439 "BLD",3584,"KRN",9.8,"NM",27,0) VAFCMSG4^^0^B13776310 "BLD",3584,"KRN",9.8,"NM",28,0) DGUTL4^^0^B10261211 "BLD",3584,"KRN",9.8,"NM","B","DGPT101",15) "BLD",3584,"KRN",9.8,"NM","B","DGPT701",12) "BLD",3584,"KRN",9.8,"NM","B","DGPT701P",13) "BLD",3584,"KRN",9.8,"NM","B","DGPTAE",14) "BLD",3584,"KRN",9.8,"NM","B","DGPTAEE2",16) "BLD",3584,"KRN",9.8,"NM","B","DGPTF1",11) "BLD",3584,"KRN",9.8,"NM","B","DGPTFTR",17) "BLD",3584,"KRN",9.8,"NM","B","DGPTFVC1",18) "BLD",3584,"KRN",9.8,"NM","B","DGPTR1",19) "BLD",3584,"KRN",9.8,"NM","B","DGPTR4",20) "BLD",3584,"KRN",9.8,"NM","B","DGRP2",21) "BLD",3584,"KRN",9.8,"NM","B","DGRPE",8) "BLD",3584,"KRN",9.8,"NM","B","DGRPH",22) "BLD",3584,"KRN",9.8,"NM","B","DGRPU1",10) "BLD",3584,"KRN",9.8,"NM","B","DGRPV",9) "BLD",3584,"KRN",9.8,"NM","B","DGUTL4",28) "BLD",3584,"KRN",9.8,"NM","B","VADPT",5) "BLD",3584,"KRN",9.8,"NM","B","VADPT0",6) "BLD",3584,"KRN",9.8,"NM","B","VADPT1",7) "BLD",3584,"KRN",9.8,"NM","B","VAFCA04",25) "BLD",3584,"KRN",9.8,"NM","B","VAFCADT2",26) "BLD",3584,"KRN",9.8,"NM","B","VAFCMSG4",27) "BLD",3584,"KRN",9.8,"NM","B","VAFCPID",3) "BLD",3584,"KRN",9.8,"NM","B","VAFHBGJ",23) "BLD",3584,"KRN",9.8,"NM","B","VAFHLPI1",2) "BLD",3584,"KRN",9.8,"NM","B","VAFHLPID",1) "BLD",3584,"KRN",9.8,"NM","B","VAFHLU",4) "BLD",3584,"KRN",9.8,"NM","B","VAFHQRY",24) "BLD",3584,"KRN",19,0) 19 "BLD",3584,"KRN",19.1,0) 19.1 "BLD",3584,"KRN",101,0) 101 "BLD",3584,"KRN",409.61,0) 409.61 "BLD",3584,"KRN",771,0) 771 "BLD",3584,"KRN",870,0) 870 "BLD",3584,"KRN",8989.51,0) 8989.51 "BLD",3584,"KRN",8989.52,0) 8989.52 "BLD",3584,"KRN",8994,0) 8994 "BLD",3584,"KRN","B",.4,.4) "BLD",3584,"KRN","B",.401,.401) "BLD",3584,"KRN","B",.402,.402) "BLD",3584,"KRN","B",.403,.403) "BLD",3584,"KRN","B",.5,.5) "BLD",3584,"KRN","B",.84,.84) "BLD",3584,"KRN","B",3.6,3.6) "BLD",3584,"KRN","B",3.8,3.8) "BLD",3584,"KRN","B",9.2,9.2) "BLD",3584,"KRN","B",9.8,9.8) "BLD",3584,"KRN","B",19,19) "BLD",3584,"KRN","B",19.1,19.1) "BLD",3584,"KRN","B",101,101) "BLD",3584,"KRN","B",409.61,409.61) "BLD",3584,"KRN","B",771,771) "BLD",3584,"KRN","B",870,870) "BLD",3584,"KRN","B",8989.51,8989.51) "BLD",3584,"KRN","B",8989.52,8989.52) "BLD",3584,"KRN","B",8994,8994) "BLD",3584,"QUES",0) ^9.62^^ "BLD",3584,"REQB",0) ^9.611^8^7 "BLD",3584,"REQB",1,0) DG*5.3*169^2 "BLD",3584,"REQB",2,0) DG*5.3*251^2 "BLD",3584,"REQB",4,0) DG*5.3*423^2 "BLD",3584,"REQB",5,0) DG*5.3*389^2 "BLD",3584,"REQB",6,0) DG*5.3*298^2 "BLD",3584,"REQB",7,0) DG*5.3*454^2 "BLD",3584,"REQB",8,0) DG*5.3*466^2 "BLD",3584,"REQB","B","DG*5.3*169",1) "BLD",3584,"REQB","B","DG*5.3*251",2) "BLD",3584,"REQB","B","DG*5.3*298",6) "BLD",3584,"REQB","B","DG*5.3*389",5) "BLD",3584,"REQB","B","DG*5.3*423",4) "BLD",3584,"REQB","B","DG*5.3*454",7) "BLD",3584,"REQB","B","DG*5.3*466",8) "DATA",10.2,1,0) HISPANIC OR LATINO^H^2135-2^2135-2^H "DATA",10.2,1,.02) "DATA",10.2,2,0) NOT HISPANIC OR LATINO^N^2186-5^2186-5^N "DATA",10.2,2,.02) "DATA",10.2,3,0) DECLINED TO ANSWER^D^0000-0^^D "DATA",10.2,4,0) UNKNOWN BY PATIENT^U^9999-4^^U "DATA",10.2,4,.02) ^ "DATA",10.3,1,0) SELF IDENTIFICATION^S^SLF^^S "DATA",10.3,2,0) PROXY^P^PRX^^P "DATA",10.3,3,0) OBSERVER^O^OBS^^O "DATA",10.3,4,0) UNKNOWN^U^UNK^^U "DATA",45.64,90,0) 713^No Longer Used (Race; field #.06)^12 "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^n^p^^^^n "FIA",2,0,10) "FIA",2,0,11) "FIA",2,0,"RLRO") "FIA",2,0,"VR") 5.3^DG "FIA",2,2) 1 "FIA",2,2,.06) "FIA",2,2,2) "FIA",2,2,6) "FIA",2,2.02) 0 "FIA",2,2.06) 0 "FIA",10) RACE "FIA",10,0) ^DIC(10, "FIA",10,0,0) 10I "FIA",10,0,1) y^n^f^^n^^n^o^n "FIA",10,0,10) "FIA",10,0,11) "FIA",10,0,"RLRO") "FIA",10,0,"VR") 5.3^DG "FIA",10,10) 0 "FIA",10,10.01) 0 "FIA",10.2) ETHNICITY "FIA",10.2,0) ^DIC(10.2, "FIA",10.2,0,0) 10.2I "FIA",10.2,0,1) y^y^f^^n^^y^o^n "FIA",10.2,0,10) "FIA",10.2,0,11) "FIA",10.2,0,"RLRO") "FIA",10.2,0,"VR") 5.3^DG "FIA",10.2,10.2) 0 "FIA",10.2,10.21) 0 "FIA",10.3) RACE AND ETHNICITY COLLECTION METHOD "FIA",10.3,0) ^DIC(10.3, "FIA",10.3,0,0) 10.3I "FIA",10.3,0,1) y^y^f^^n^^y^o^n "FIA",10.3,0,10) "FIA",10.3,0,11) "FIA",10.3,0,"RLRO") "FIA",10.3,0,"VR") 5.3^DG "FIA",10.3,10.3) 0 "FIA",45.64) PTF AUSTIN ERROR CODES "FIA",45.64,0) ^DGP(45.64, "FIA",45.64,0,0) 45.64 "FIA",45.64,0,1) n^n^f^^n^^y^o^n "FIA",45.64,0,10) "FIA",45.64,0,11) I $P(^(0),"^",1)=713 "FIA",45.64,0,"RLRO") "FIA",45.64,0,"VR") 5.3^DG "FIA",45.64,45.64) 0 "INI") PRE^DG53415 "INIT") POST^DG53415 "IX",2,2.06,"AONLYONE",0) 2.06^AONLYONE^Only one entry allowed in multiple^MU^^F^^I^2.06^^^^^A "IX",2,2.06,"AONLYONE",.1,0) ^^3^3^3020709^ "IX",2,2.06,"AONLYONE",.1,1,0) Cross reference deletes all entries in the multiple EXCEPT the one just "IX",2,2.06,"AONLYONE",.1,2,0) added. This has the net affect of only allowing one entry to exist in the "IX",2,2.06,"AONLYONE",.1,3,0) multiple. "IX",2,2.06,"AONLYONE",1) N DGFDA,DGMSG,DGD0,DGD1,DGLOOP S DGD0=DA(1),DGD1=DA S DGLOOP=0 F S DGLOOP=$O(^DPT(DGD0,.06,DGLOOP)) Q:'DGLOOP I DGLOOP'=DGD1 S DGFDA(2.06,DGLOOP_","_DGD0_",",.01)="@" D FILE^DIE("","DGFDA","DGMSG") K DGFDA,DGMSG "IX",2,2.06,"AONLYONE",2) Q "IX",2,2.06,"AONLYONE",11.1,0) ^.114IA^1^1 "IX",2,2.06,"AONLYONE",11.1,1,0) 1^F^2.06^.01^^^F "KRN",.402,83,-1) 0^1 "KRN",.402,83,0) DG101^3020718.1042^^45^^^3021230 "KRN",.402,83,"DIAB",1,0,45,1) PATIENT: "KRN",.402,83,"DIAB",1,2,2.02,0) .01;"RACE" "KRN",.402,83,"DIAB",1,2,2.06,0) .01;"ETHNICITY" "KRN",.402,83,"DIAB",4,1,2,0) 6;"ETHNICITY" "KRN",.402,83,"DIAB",5,1,2,0) 2;"RACE" "KRN",.402,83,"DIAB",6,0,45,0) SOURCE OF ADMISSION;REQ "KRN",.402,83,"DR",1,45) S:+DGJUMP'=1 Y="@99";@1;S DGJUMP=$P(DGJUMP,"1,",2);3//^S X=$P($$SITE^VASITE,U,3);5;20R~;22;21.1;21.2;20.1////^S X=$$ELIG^DGUTL3(DFN,1,$P($G(^DGPT(DA,101)),U,8));I DGPTFMT>1 S Y="@10";23;@10;S:+DGJUMP'=2 Y="@99";@2;@3;@4; "KRN",.402,83,"DR",1,45,1) ^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:"");S:+DGJUMP'=5 Y="@99";@5;S DGJUMP=$P(DGJUMP,"5,",2);75;S:+DGJUMP'=6 Y="@99";@6;S DGJUMP=$P(DGJUMP,"6,",2);73;74; "KRN",.402,83,"DR",1,45,2) S:DGJUMP'=7 Y="@99";@7;S DGJUMP=$P(DGJUMP,"7,",2);76.1;76.2;78;77;@99;S:+DGJUMP Y="@"_+DGJUMP; "KRN",.402,83,"DR",2,2) S:+DGJUMP'=2 Y="@991";S DGJUMP=$P(DGJUMP,"2,",2);.05;6ETHNICITY~;2RACE~;.02;.03;57.4;S:+DGJUMP'=3 Y="@991";@31;S DGJUMP=$P(DGJUMP,"3,",2);.32101;.32102;S:X'="Y" Y=.32103;.3213;.32103;S:X'="Y" Y=.525;.3212;.525;S:X'="Y" Y="@42"; "KRN",.402,83,"DR",2,2,1) .526;@42;S:+DGJUMP'=4 Y="@991";@41;S DGJUMP=$P(DGJUMP,"4,",2);.115;.1112;.117;@991;I +DGJUMP>2&(+DGJUMP<5) S Y="@"_+DGJUMP_1; "KRN",.402,83,"DR",3,2.02) .01RACE~;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,83,"DR",3,2.06) .01ETHNICITY~;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,83,"ROU") ^DGPTX1 "KRN",.402,83,"ROUOLD") DGPTX1 "KRN",.402,84,-1) 0^2 "KRN",.402,84,0) DG101F^3020718.1119^^45^^^3020718 "KRN",.402,84,"DIAB",1,0,45,1) PATIENT: "KRN",.402,84,"DIAB",1,2,2.02,0) .01;"RACE" "KRN",.402,84,"DIAB",1,2,2.06,0) .01;"ETHNICITY" "KRN",.402,84,"DIAB",4,1,2,0) 6;"ETHNICITY" "KRN",.402,84,"DIAB",5,1,2,0) 2;"RACE" "KRN",.402,84,"DIAB",6,0,45,0) 20;REQ "KRN",.402,84,"DR",1,45) S:+DGJUMP'=1 Y="@99";@1;S DGJUMP=$P(DGJUMP,"1,",2);3//^S X=$P($$SITE^VASITE,U,3);5;20R~;22;21.1;21.2;20.1////^S X=$$ELIG^DGUTL3(DFN,1,$P($G(^DGPT(DA,101)),U,8));I DGPTFMT>1 S Y="@10";23;@10;S:+DGJUMP'=2 Y="@99";@2;@3;@4; "KRN",.402,84,"DR",1,45,1) ^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:"");S:+DGJUMP'=5 Y="@99";@5;S DGJUMP=$P(DGJUMP,"5,",2);70;71;72;72.1;75;10;S:+DGJUMP'=6 Y="@99";@6; "KRN",.402,84,"DR",1,45,2) S DGJUMP=$P(DGJUMP,"6,",2);73;74;S:DGJUMP'=7 Y="@99";@7;S DGJUMP=$P(DGJUMP,"7,",2);76.1;76.2;78;77;@99;S:+DGJUMP Y="@"_+DGJUMP; "KRN",.402,84,"DR",2,2) S:+DGJUMP'=2 Y="@991";S DGJUMP=$P(DGJUMP,"2,",2);.05;6ETHNICITY~;2RACE~;.02;.03;57.4;S:+DGJUMP'=3 Y="@991";@31;S DGJUMP=$P(DGJUMP,"3,",2);.32101;.32102;S:X'="Y" Y=.32103;.3213;.32103;S:X'="Y" Y=.525;.3212;.525;S:X'="Y" Y="@42"; "KRN",.402,84,"DR",2,2,1) .526;@42;S:+DGJUMP'=4 Y="@991";@41;S DGJUMP=$P(DGJUMP,"4,",2);.115;.1112;.117;@991;I +DGJUMP>2&(+DGJUMP<5) S Y="@"_+DGJUMP_1; "KRN",.402,84,"DR",3,2.02) .01RACE~;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,"DR",3,2.06) .01ETHNICITY~;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,539,-1) 0^3 "KRN",.402,539,0) DGQWK^3020718.1121^^45^^^3020718 "KRN",.402,539,"DIAB",1,2,2.02,0) .01;"RACE" "KRN",.402,539,"DIAB",1,2,2.06,0) .01;"ETHNICITY" "KRN",.402,539,"DIAB",2,1,2,0) 6;"ETHNICITY" "KRN",.402,539,"DIAB",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($$SITE^VASITE,U,3);5;20;22;21.1;21.2;20.1////^S X=$$ELIG^DGUTL3(DFN,2,$P($G(^DGPT(DA,101)),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:"");75;73;74; "KRN",.402,539,"DR",1,45,1) 76.1;76.2;78;77; "KRN",.402,539,"DR",2,2) .05;6ETHNICITY~;2RACE~;.02;.03;57.4;.32101;.32102;S:X'="Y" Y=.32103;.3213;.32103;S:X'="Y" Y=.525;.3212;.525;S:X'="Y" Y=.115;.526;.115;.1112;.117; "KRN",.402,539,"DR",3,2.02) .01RACE~;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,539,"DR",3,2.06) .01ETHNICITY~;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^4 "KRN",.402,540,0) DGQWKF^3020718.1122^^45^^^3020718 "KRN",.402,540,"DIAB",1,2,2.02,0) .01;"RACE" "KRN",.402,540,"DIAB",1,2,2.06,0) .01;"ETHNICITY" "KRN",.402,540,"DIAB",2,1,2,0) 6;"ETHNICITY" "KRN",.402,540,"DIAB",3,1,2,0) 2;"RACE" "KRN",.402,540,"DIAB",8,0,45,0) PATIENT: "KRN",.402,540,"DR",1,45) 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,101)),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:"");10;70;71; "KRN",.402,540,"DR",1,45,1) 72;72.1;75;73;74;76.1;76.2;78;77; "KRN",.402,540,"DR",2,2) .05;6ETHNICITY~;2RACE~;.02;.03;57.4;.32101;.32102;S:X'="Y" Y=.32103;.3213;.32103;S:X'="Y" Y=.525;.3212;.525;S:X'="Y" Y=.115;.526;.115;.1112;.117; "KRN",.402,540,"DR",3,2.02) .01RACE~;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,540,"DR",3,2.06) .01ETHNICITY~;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),"^",2),0)),"^",2)="S" S Y="@61";.02;@61; "MBREQ") 0 "ORD",7,.402) .402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "ORD",7,.402,0) INPUT TEMPLATE "PKG",114,-1) 1^1 "PKG",114,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",114,20,0) ^9.402P^^ "PKG",114,22,0) ^9.49I^1^1 "PKG",114,22,1,0) 5.3^2930813^2930821 "PKG",114,22,1,"PAH",1,0) 415^3030102^1934 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 29 "RTN","DG53415") 0^^B26675162 "RTN","DG53415",1,0) DG53415 ;BPFO/JRP - PRE/POST INITS FOR PATCH 415;7/11/2002 ; 11/5/02 12:45pm "RTN","DG53415",2,0) ;;5.3;Registration;**415**;Aug 13, 1993 "RTN","DG53415",3,0) ; "RTN","DG53415",4,0) Q "RTN","DG53415",5,0) ; "RTN","DG53415",6,0) PRE ;Pre-init entry point "RTN","DG53415",7,0) N JUNK1,JUNK2,SUBFILE "RTN","DG53415",8,0) ;Delete obsolete sub-files "RTN","DG53415",9,0) F SUBFILE=2.02,2.06 I $D(^DD(SUBFILE)) D "RTN","DG53415",10,0) .;Don't delete if the obsolete sub-file isn't there "RTN","DG53415",11,0) .N DEL,X "RTN","DG53415",12,0) .S DEL=0 "RTN","DG53415",13,0) .S X=0 F S X=+$O(^DD(2,"SB",SUBFILE,X)) Q:'X D Q:DEL "RTN","DG53415",14,0) ..I SUBFILE=2.02 S:(X'=2) DEL=1 "RTN","DG53415",15,0) ..I SUBFILE=2.06 S:(X'=6) DEL=1 "RTN","DG53415",16,0) .Q:'DEL "RTN","DG53415",17,0) .;Remove reference to correct sub-file "RTN","DG53415",18,0) .S X=$S(SUBFILE=2.02:2,1:6) K ^DD(2,"SB",SUBFILE,X) "RTN","DG53415",19,0) .;Delete sub-file "RTN","DG53415",20,0) .S JUNK1(1)=" " "RTN","DG53415",21,0) .S JUNK1(2)="The new "_$S(SUBFILE=2.02:"RACE",1:"ETHNICITY")_" INFORMATION multiple is contained in" "RTN","DG53415",22,0) .S JUNK1(3)="an obsolete sub-file that still exists on your system." "RTN","DG53415",23,0) .S JUNK1(4)="The obsolete sub-file (#"_SUBFILE_") will now be deleted." "RTN","DG53415",24,0) .S JUNK1(5)=" " "RTN","DG53415",25,0) .D MES^XPDUTL(.JUNK1) K JUNK1 "RTN","DG53415",26,0) .N DIU "RTN","DG53415",27,0) .S DIU=SUBFILE "RTN","DG53415",28,0) .S DIU(0)="DST" "RTN","DG53415",29,0) .D EN^DIU2 "RTN","DG53415",30,0) ;Delete "bad" B x-reference on RACE file (patch brings in "good" one) "RTN","DG53415",31,0) S JUNK1(1)=" " "RTN","DG53415",32,0) S JUNK1(2)="The B cross reference on the RACE file (#10) may be listed" "RTN","DG53415",33,0) S JUNK1(3)="as the second cross reference of the NAME field (#.01)" "RTN","DG53415",34,0) S JUNK1(4)="instead of the first. To ensure that the B cross" "RTN","DG53415",35,0) S JUNK1(5)="reference is listed as the first cross reference, the" "RTN","DG53415",36,0) S JUNK1(6)="second cross reference of the NAME field will now be" "RTN","DG53415",37,0) S JUNK1(7)="deleted." "RTN","DG53415",38,0) S JUNK1(8)=" " "RTN","DG53415",39,0) D MES^XPDUTL(.JUNK1) K JUNK1 "RTN","DG53415",40,0) D DELIX^DDMOD(10,.01,2,"W","JUNK1","JUNK2") "RTN","DG53415",41,0) Q "RTN","DG53415",42,0) ; "RTN","DG53415",43,0) POST ;Post-init entry point "RTN","DG53415",44,0) N JUNK,DIK,RACES,IEN "RTN","DG53415",45,0) ;Rebuild B x-reference on RACE file "RTN","DG53415",46,0) S JUNK(1)=" " "RTN","DG53415",47,0) S JUNK(2)="The incorrect B cross reference on the RACE file (#10)," "RTN","DG53415",48,0) S JUNK(3)="which was removed by the pre-init, placed the entire value" "RTN","DG53415",49,0) S JUNK(4)="of the NAME field (#.01) into the cross reference. The" "RTN","DG53415",50,0) S JUNK(5)="correct logic for the B cross reference only places the" "RTN","DG53415",51,0) S JUNK(6)="first thirty characters into the cross reference. To" "RTN","DG53415",52,0) S JUNK(7)="ensure that the cross referenced values are correct, the" "RTN","DG53415",53,0) S JUNK(8)="entire B cross reference will now be deleted and then" "RTN","DG53415",54,0) S JUNK(9)="reindexed." "RTN","DG53415",55,0) S JUNK(10)=" " "RTN","DG53415",56,0) D MES^XPDUTL(.JUNK) K JUNK "RTN","DG53415",57,0) K ^DIC(10,"B") "RTN","DG53415",58,0) S DIK="^DIC(10," "RTN","DG53415",59,0) S DIK(1)=".01^B" "RTN","DG53415",60,0) D ENALL^DIK K DIK "RTN","DG53415",61,0) ;Inactivate all races "RTN","DG53415",62,0) S JUNK(1)=" " "RTN","DG53415",63,0) S JUNK(2)="Marking all entries in the RACE file (#10) as inactive" "RTN","DG53415",64,0) S JUNK(3)=" " "RTN","DG53415",65,0) D MES^XPDUTL(.JUNK) K JUNK "RTN","DG53415",66,0) S IEN=0 "RTN","DG53415",67,0) F S IEN=+$O(^DIC(10,IEN)) Q:'IEN D "RTN","DG53415",68,0) .N FDAROOT,MSGROOT,IENS "RTN","DG53415",69,0) .S IENS=IEN_"," "RTN","DG53415",70,0) .S FDAROOT(10,IENS,200)=1 "RTN","DG53415",71,0) .S FDAROOT(10,IENS,202)=$P($$NOW^XLFDT(),".",1) "RTN","DG53415",72,0) .D FILE^DIE("K","FDAROOT","MSGROOT") "RTN","DG53415",73,0) .I $D(MSGROOT) D "RTN","DG53415",74,0) ..S JUNK(1)=" **" "RTN","DG53415",75,0) ..S JUNK(2)=" ** ERROR" "RTN","DG53415",76,0) ..S JUNK(3)=" ** Unable to inactivate entry number "_IEN "RTN","DG53415",77,0) ..S JUNK(4)=" ** Entry should be inactivated via FileMan" "RTN","DG53415",78,0) ..S JUNK(5)=" **" "RTN","DG53415",79,0) ..D MES^XPDUTL(.JUNK) K JUNK "RTN","DG53415",80,0) ;Create/update national entries "RTN","DG53415",81,0) S JUNK(1)=" " "RTN","DG53415",82,0) S JUNK(2)="Creating/updating nationally supported entries in the RACE" "RTN","DG53415",83,0) S JUNK(3)="file (#10)" "RTN","DG53415",84,0) S JUNK(4)=" " "RTN","DG53415",85,0) D MES^XPDUTL(.JUNK) K JUNK "RTN","DG53415",86,0) D BLDLST(.RACES) "RTN","DG53415",87,0) S IEN=0 "RTN","DG53415",88,0) F S IEN=+$O(RACES("FDA",IEN)) Q:'IEN D "RTN","DG53415",89,0) .N FDAROOT,IENROOT,MSGROOT,IENS,TMP "RTN","DG53415",90,0) .S TMP=RACES("FDA",IEN,.01) "RTN","DG53415",91,0) .S IENS=+$O(^DIC(10,"B",$E(TMP,1,30),0)) S:'IENS IENS="+1" "RTN","DG53415",92,0) .S IENS=IENS_"," "RTN","DG53415",93,0) .M FDAROOT(10,IENS)=RACES("FDA",IEN) "RTN","DG53415",94,0) .D UPDATE^DIE("","FDAROOT","IENROOT","MSGROOT") "RTN","DG53415",95,0) .I $D(MSGROOT) D "RTN","DG53415",96,0) ..S JUNK(1)=" **" "RTN","DG53415",97,0) ..S JUNK(2)=" ** ERROR" "RTN","DG53415",98,0) ..S JUNK(3)=" ** Unable to create entry for "_RACES("FDA",IEN,.01) "RTN","DG53415",99,0) ..S JUNK(4)=" ** Entry should be created via FileMan" "RTN","DG53415",100,0) ..S JUNK(5)=" ** Name (.01): "_RACES("FDA",IEN,.01) "RTN","DG53415",101,0) ..S JUNK(6)=" ** Abbrev (2): "_RACES("FDA",IEN,2) "RTN","DG53415",102,0) ..S JUNK(7)=" ** HL7 Val (3): "_RACES("FDA",IEN,3) "RTN","DG53415",103,0) ..S JUNK(8)=" ** CDC Val (4): "_RACES("FDA",IEN,4) "RTN","DG53415",104,0) ..S JUNK(9)=" ** PTF Val (5): "_RACES("FDA",IEN,5) "RTN","DG53415",105,0) ..S JUNK(10)=" **" "RTN","DG53415",106,0) ..D MES^XPDUTL(.JUNK) K JUNK "RTN","DG53415",107,0) ;Delete RACE identifier "RTN","DG53415",108,0) S JUNK(1)=" " "RTN","DG53415",109,0) S JUNK(2)="Removing old RACE field (#.06) as an identifier of the" "RTN","DG53415",110,0) S JUNK(3)="PATIENT file (#2)." "RTN","DG53415",111,0) S JUNK(4)=" " "RTN","DG53415",112,0) D MES^XPDUTL(.JUNK) K JUNK "RTN","DG53415",113,0) K ^DD(2,0,"ID",.06) "RTN","DG53415",114,0) Q "RTN","DG53415",115,0) ; "RTN","DG53415",116,0) BLDLST(ARRAY) ;Build list of valid races "RTN","DG53415",117,0) ;Input : ARRAY - Array to place values into (pass by value) "RTN","DG53415",118,0) ;Output : ARRAY("FDA",X,Field) = Value "RTN","DG53415",119,0) ;Notes : ARRAY will be initiallized (killed) on entry "RTN","DG53415",120,0) ; : Assumes ARRAY is input "RTN","DG53415",121,0) ; "RTN","DG53415",122,0) N LOOP,TEXT,STOP,X "RTN","DG53415",123,0) K ARRAY "RTN","DG53415",124,0) S (STOP,LOOP)=0 "RTN","DG53415",125,0) F S LOOP=LOOP+1 D Q:STOP "RTN","DG53415",126,0) .S TEXT=$P($T(RACES+LOOP),";;",2) "RTN","DG53415",127,0) .S X=$P(TEXT,"^",1) "RTN","DG53415",128,0) .I X="" S STOP=1 Q "RTN","DG53415",129,0) .S ARRAY("FDA",LOOP,.01)=X "RTN","DG53415",130,0) .F X=2:1:5 S ARRAY("FDA",LOOP,X)=$P(TEXT,"^",X) "RTN","DG53415",131,0) .S ARRAY("FDA",LOOP,200)="@" "RTN","DG53415",132,0) .S ARRAY("FDA",LOOP,202)="@" "RTN","DG53415",133,0) Q "RTN","DG53415",134,0) ; "RTN","DG53415",135,0) RACES ;RACE (#.01)^ABBREVIATION (#2)^HL7 (#3)^CDC (#4)^PTF (#5) "RTN","DG53415",136,0) ;;AMERICAN INDIAN OR ALASKA NATIVE^3^1002-5^1002-5^3 "RTN","DG53415",137,0) ;;ASIAN^A^2028-9^2028-9^8 "RTN","DG53415",138,0) ;;BLACK OR AFRICAN AMERICAN^B^2054-5^2054-5^9 "RTN","DG53415",139,0) ;;DECLINED TO ANSWER^D^0000-0^^C "RTN","DG53415",140,0) ;;NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER^H^2076-8^2076-8^A "RTN","DG53415",141,0) ;;UNKNOWN BY PATIENT^U^9999-4^^D "RTN","DG53415",142,0) ;;WHITE^W^2106-3^2106-3^B "RTN","DG53415",143,0) ;; "RTN","DGPT101") 0^15^B12471768 "RTN","DGPT101",1,0) DGPT101 ;ALB/MTC - 101/701 Austin Edit Checks ; 12 NOV 92 "RTN","DGPT101",2,0) ;;5.3;Registration;**8,164,180,247,415**;Aug 13, 1993 "RTN","DGPT101",3,0) ; "RTN","DGPT101",4,0) EN ; "RTN","DGPT101",5,0) S (DGPTFEF,DGPTERC)=0 "RTN","DGPT101",6,0) 101 ;-- process 101+701 data "RTN","DGPT101",7,0) N ERROR "RTN","DGPT101",8,0) ; "RTN","DGPT101",9,0) PARSE ;Set up record string, Call routine to parse record "RTN","DGPT101",10,0) S DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ) "RTN","DGPT101",11,0) D SET^DGPT101P "RTN","DGPT101",12,0) D NOW^%DTC S DGPTTY=(17+$E(X,1))_$E(X,2,3) "RTN","DGPT101",13,0) 701 ;PROCESS 701 "RTN","DGPT101",14,0) S DGPTAL7=$O(^TMP("AEDIT",$J,"N701",SEQ)) I DGPTAL7="" S DGPTFEF=1 Q "RTN","DGPT101",15,0) D SET^DGPT701 I DGPTFEF Q "RTN","DGPT101",16,0) SET ; Start error piece, flags "RTN","DGPT101",17,0) S DGPTEDFL=0,DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ) "RTN","DGPT101",18,0) SSN ; Start edits "RTN","DGPT101",19,0) I DGPTSSN'?9N!((DGPTPS=" ")&("9"[$E(DGPTSSN))) S DGPTERC=102 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",20,0) I " P"'[DGPTPS S DGPTERC=101 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",21,0) S DGPTPS=$S(DGPTPS="P":DGPTPS,1:"A") "RTN","DGPT101",22,0) PSEU ; "RTN","DGPT101",23,0) I DGPTPS="P" S DGPTERC=0 D PSE^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",24,0) DTE ; "RTN","DGPT101",25,0) S X=DGPTDTS,%DT="XT" D ^%DT I Y<0 S DGPTERC=103 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",26,0) I Y>0 D DD^%DT S DGPTADT=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00") "RTN","DGPT101",27,0) S X1=DGPTNOW,X2=$$FMDT($E(DGPTSTR,15,20)) D ^%DTC I X<0 S DGPTERC=140 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",28,0) S DGPTDTS=$$FMDT($E(DGPTSTR,15,20))_"."_$E(DGPTSTR,21,24) "RTN","DGPT101",29,0) LN ; "RTN","DGPT101",30,0) I DGPTLN'?1.U." " S DGPTERC=105 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",31,0) I DGPTFI'?.U!((DGPTMI'?1U)&(DGPTMI'=" ")) S DGPTERC=106 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",32,0) SRA ;-- may need to add more edits later "RTN","DGPT101",33,0) D ^DGPT10S1 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",34,0) SRP ; "RTN","DGPT101",35,0) N I "RTN","DGPT101",36,0) S DGPTERC=0 "RTN","DGPT101",37,0) I " 1234"'[DGPTSRP S DGPTERC=109 D ERR G:DGPTEDFL EXIT G POW "RTN","DGPT101",38,0) I "1234"[DGPTSRP S DGPTERC=109 F I=20:1:26 I DGPTSTTY[U_I_U S DGPTERC=0 Q "RTN","DGPT101",39,0) I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",40,0) POW ; "RTN","DGPT101",41,0) I $L(DGPTPOW)'=1!("123456789AB "'[DGPTPOW) S DGPTERC=110 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",42,0) MAR ; "RTN","DGPT101",43,0) I "MWDUSN"'[DGPTMRS S DGPTERC=111 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",44,0) GEN ; "RTN","DGPT101",45,0) I "FM"'[DGPTGEN S DGPTERC=112 D ERR G:DGPTEDFL EXIT "RTN","DGPT101",46,0) S DGPTGEN1=$S(DGPTGEN="F":1,1:0) "RTN","DGPT101",47,0) DOB ; "RTN","DGPT101",48,0) S DGPTERC=0 D DB^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",49,0) POS ; "RTN","DGPT101",50,0) S DGPTERC=0 D ^DGPT10CB I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",51,0) EXP ; "RTN","DGPT101",52,0) S DGPTERC=0 D AGO^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",53,0) S DGPTERC=0 D IRAD^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",54,0) HOME ; "RTN","DGPT101",55,0) S DGPTERC=0 D STATE^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",56,0) S DGPTERC=0 D CNTY^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",57,0) S DGPTERC=0 D ZIP^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",58,0) MT ; "RTN","DGPT101",59,0) S DGPTERC=0 D MT^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",60,0) INCOM ; "RTN","DGPT101",61,0) I DGPTDDS<2911001 G GOOD "RTN","DGPT101",62,0) S DGPTERC=0 D INC^DGPTAE01 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT101",63,0) GOOD ; "RTN","DGPT101",64,0) W:'$D(ERROR) "." "RTN","DGPT101",65,0) ; "RTN","DGPT101",66,0) EXIT ; "RTN","DGPT101",67,0) K DGPTREC,DGPTORBD,DGPTLN,DGPTFI,DGPTMI,DGPTMRS,DGPTSTE,DGPTCTY,DGPTZIP,DGPTINC "RTN","DGPT101",68,0) K DGPTSRA,DGPTTF,DGPTSRP,DGPTPOS1,DGPTEXA,DGPTEXI,DGPTMTC,DGPTDTD,DGPTDSP,DGPTDTY,DGPTDOP,DGPTDVA,DGPTDPD,DGPTDRF,DGPTDAS,DGPTDCP,DGPTDDXE,DGPTDDXO,DGPTDLR,DGPTDLC,DGPTDSC,DGPTDAGE,DGPTDRG,DGPTSTR "RTN","DGPT101",69,0) K DGPT70LG,DGPT70SU,DGPT70DR,DGPT70X4,DGPTDXV1,DGPTDXV2 "RTN","DGPT101",70,0) Q "RTN","DGPT101",71,0) ERR ; "RTN","DGPT101",72,0) D WRTERR^DGPTAE(DGPTERC,NODE,SEQ) "RTN","DGPT101",73,0) S ERROR=1 "RTN","DGPT101",74,0) Q "RTN","DGPT101",75,0) FMDT(X) ; change to fm date for y2k "RTN","DGPT101",76,0) N Y "RTN","DGPT101",77,0) D ^%DT "RTN","DGPT101",78,0) Q Y "RTN","DGPT701") 0^12^B13169396 "RTN","DGPT701",1,0) DGPT701 ;ALB/MTC - Process 701 Transaction ;10/06/1999 "RTN","DGPT701",2,0) ;;5.3;Registration;**64,164,251,415**;Aug 13, 1993 "RTN","DGPT701",3,0) ; 10/06/1999 ACS - Removed Place of Disposition codes M,Y,Z from the list of "RTN","DGPT701",4,0) ; invalid codes. "RTN","DGPT701",5,0) ; "RTN","DGPT701",6,0) EN ; "RTN","DGPT701",7,0) Q "RTN","DGPT701",8,0) SET ; "RTN","DGPT701",9,0) S DGPTSTR=$G(^TMP("AEDIT",$J,"N701",DGPTAL7)) "RTN","DGPT701",10,0) D PARSE^DGPT701P "RTN","DGPT701",11,0) DTE ; "RTN","DGPT701",12,0) S (X,DGPTDDS)=$$FMDT^DGPT101($E(DGPTDDTD,1,6))_"."_$E(DGPTDDTD,7,10) "RTN","DGPT701",13,0) S %DT="XT" D ^%DT I Y<0 S DGPTERC=705 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",14,0) I Y>0 D DD^%DT S DGPTDTD=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00") "RTN","DGPT701",15,0) S X1=DGPTNOW,X2=+DGPTDDS D ^%DTC I X<0 S DGPTERC=740 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",16,0) S X1=+DGPTDDS,X2=+DGPTDTS D ^%DTC S DGPTELP=X I X<0 S DGPTERC=737 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",17,0) CHECK ; "RTN","DGPT701",18,0) TSPEC ; CHECK TREATING SPECIALTY CODE "RTN","DGPT701",19,0) I DGPTDSP'?2N S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY "RTN","DGPT701",20,0) S DGPTSP1=$E(DGPTDSP,1),DGPTSP2=$E(DGPTDSP,2),DGPTERC=0 "RTN","DGPT701",21,0) D CHECK^DGPTAE02 I DGPTERC S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY "RTN","DGPT701",22,0) ;-- Active treating specialty edit check "RTN","DGPT701",23,0) I $E(DGPTDSP,1)=0!($E(DGPTDSP,1)=" ") S DGPTDSP=$E(DGPTDSP,2) "RTN","DGPT701",24,0) ;-- If not active treat spec, set flag to print error msg during "RTN","DGPT701",25,0) ;-- PTF Close-out Error display at WRER^DGPTAEE "RTN","DGPT701",26,0) I '$$ACTIVE^DGACT(42.4,DGPTDSP,DGPTDDS) S DGPTERC=706,DGPTSER(DGPTDDS_701)=1 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",27,0) ; "RTN","DGPT701",28,0) DISPTY ; "RTN","DGPT701",29,0) I (DGPTDTY<1)!(DGPTDTY>7) S DGPTERC=707 D ERR G:DGPTEDFL EXIT G OPCAR "RTN","DGPT701",30,0) S DGPTERC=0 D DISPTY^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",31,0) OPCAR ; "RTN","DGPT701",32,0) I "13 "'[DGPTDOP S DGPTERC=708 D ERR G:DGPTEDFL EXIT G VA "RTN","DGPT701",33,0) I DGPTDOP'=" " S DGPTERC=0 D OP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",34,0) VA ; "RTN","DGPT701",35,0) I "12 "'[DGPTDVA S DGPTERC=709 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",36,0) ; "RTN","DGPT701",37,0) VAOP ;-- check for inconsistencies between opcare and va aspices "RTN","DGPT701",38,0) I DGPTDVA=2,DGPTDOP=1 D G:DGPTEDFL EXIT "RTN","DGPT701",39,0) . S DGPTERC=708 D ERR "RTN","DGPT701",40,0) . S DGPTERC=709 D ERR "RTN","DGPT701",41,0) CDR ; "RTN","DGPT701",42,0) I DGPTDLR'?6" "&(DGPTDLR'?." "6N) S DGPTERC=775 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",43,0) POD ; "RTN","DGPT701",44,0) ;I "68EIMNOQSVWYZ"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF "RTN","DGPT701",45,0) I "68EINOQSVW"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF "RTN","DGPT701",46,0) S DGPTERC=0 D POD^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",47,0) RECF ; "RTN","DGPT701",48,0) I DGPTDVA'=1!(DGPTDRF=" ") G ASIH "RTN","DGPT701",49,0) I DGPTDRF[" " S DGPTDRF=$P(DGPTDRF," ",1) "RTN","DGPT701",50,0) I DGPTDRF="" S DGPTERC=711 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",51,0) ASIH ; "RTN","DGPT701",52,0) I DGPTDAS'=" ",DGPTDAS'?2E1N S DGPTERC=712 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",53,0) ; "RTN","DGPT701",54,0) LEAVE ; "RTN","DGPT701",55,0) S DGPTERC=0 D LEAVE^DGPTAE02 D:DGPTERC ERR G:DGPTEDFL EXIT "RTN","DGPT701",56,0) SC ; "RTN","DGPT701",57,0) I DGPTDSC'=" "&(DGPTDSC'?3N) S DGPTERC=730 D ERR G:DGPTEDFL EXIT G CP "RTN","DGPT701",58,0) S DGPTDSC=+DGPTDSC "RTN","DGPT701",59,0) CP ; "RTN","DGPT701",60,0) S DGPTERC=0 D CANDP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",61,0) DIAG ; "RTN","DGPT701",62,0) S DGPTERC=0 D ^DGPT70DX I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",63,0) OVER ; Pass FY92 edits for earlier data "RTN","DGPT701",64,0) I DGPTDDS'>2911001 G ONED "RTN","DGPT701",65,0) LEG ; LEGIONNAIRE'S DISEASE "RTN","DGPT701",66,0) S DGPTERC=0 D LEG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",67,0) SUI ; Suicide indicator "RTN","DGPT701",68,0) S DGPTERC=0 D SUI^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",69,0) DRUG ; "RTN","DGPT701",70,0) S DGPTERC=0 D DRUG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",71,0) AXES ; Psych axises "RTN","DGPT701",72,0) I '$P($G(^DIC(42.4,+DGPTDSP,0)),U,4) S (DGPT70X4,DGPT7X51,DGPT7X52)=" " G ONED "RTN","DGPT701",73,0) S DGPTERC=0 D AXIV^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",74,0) S DGPTERC=0 D AXV1^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",75,0) S DGPTERC=0 D AXV2^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT "RTN","DGPT701",76,0) ONED ; "RTN","DGPT701",77,0) I (DGPTDDXO=" ")&('$D(^TMP("AEDIT",$J,"N702"))&'$D(^TMP("AEDIT",$J,"N703"))) S DGPTERC=718 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",78,0) I (DGPTDDXO="X")&($D(^TMP("AEDIT",$J,"N072"))) S DGPTERC=719 D ERR G:DGPTEDFL EXIT "RTN","DGPT701",79,0) EXIT ; "RTN","DGPT701",80,0) Q "RTN","DGPT701",81,0) ERR ; "RTN","DGPT701",82,0) D WRTERR^DGPTAE(DGPTERC,"N701",DGPTAL7) "RTN","DGPT701",83,0) S ERROR=1 "RTN","DGPT701",84,0) Q "RTN","DGPT701P") 0^13^B2908139 "RTN","DGPT701P",1,0) DGPT701P ;ALB/MTC - Parse 701 Record String ; 13 NOV 92 "RTN","DGPT701P",2,0) ;;5.3;Registration;**164,415**;Aug 13, 1993 "RTN","DGPT701P",3,0) ; "RTN","DGPT701P",4,0) EN ; "RTN","DGPT701P",5,0) PARSE ; Parse record string "RTN","DGPT701P",6,0) S DGPTDDTD=$E(DGPTSTR,31,40),DGPTDDS=$$FMDT^DGPT101($E(DGPTDDTD,1,6))_"."_$E(DGPTDDTD,7,10) "RTN","DGPT701P",7,0) S DGPTDSP=$E(DGPTSTR,41,42),DGPTDTY=$E(DGPTSTR,43) "RTN","DGPT701P",8,0) S DGPTDOP=$E(DGPTSTR,44),DGPTDVA=$E(DGPTSTR,45),DGPTDPD=$E(DGPTSTR,46),DGPTDRF=$E(DGPTSTR,47,52),DGPTDAS=$E(DGPTSTR,53,55),DGPTDCP=$E(DGPTSTR,57),DGPTDDXE=$E(DGPTSTR,58,64),DGPTDDXO=$E(DGPTSTR,65) "RTN","DGPT701P",9,0) S DGPTDLR=$E(DGPTSTR,66,71),DGPTDLC=$E(DGPTSTR,72,73),DGPTDSC=$E(DGPTSTR,74,76) "RTN","DGPT701P",10,0) S DGPT70LG=$E(DGPTSTR,77),DGPT70SU=$E(DGPTSTR,78),DGPT70DR=$E(DGPTSTR,79,82),DGPT70X4=$E(DGPTSTR,83),DGPTDXV1=$E(DGPTSTR,84,85),DGPTDXV2=$E(DGPTSTR,86,87) "RTN","DGPT701P",11,0) Q "RTN","DGPTAE") 0^14^B14522606 "RTN","DGPTAE",1,0) DGPTAE ;ALB/MTC - Austin Edit Checks Driver ; 12 NOV 92 "RTN","DGPTAE",2,0) ;;5.3;Registration;**58,415**;Aug 13, 1993 "RTN","DGPTAE",3,0) ; "RTN","DGPTAE",4,0) ; Check for 101, 501, 701; Route processing by type; call DRG and output routine "RTN","DGPTAE",5,0) EN ; "RTN","DGPTAE",6,0) N DGPTERP,DGPTERC,DGPRS,DGPTEDFL,DGPTNOW,DGPTFAC "RTN","DGPTAE",7,0) S (DGPTEDFL,DGPTERP)=0,DGPRS="N101^N501^N601^N701^N702^N703^N401^N402^N403^N535^" "RTN","DGPTAE",8,0) D NOW^%DTC S DGPTNOW=+X "RTN","DGPTAE",9,0) ;-- check if record available to process "RTN","DGPTAE",10,0) I '$D(^TMP("AEDIT")) G EXIT "RTN","DGPTAE",11,0) ;-- check if all nodes are present "RTN","DGPTAE",12,0) S DGPTERC=$$PRES() I DGPTERC D WRTERR(DGPTERC,"N101",1) G EXIT "RTN","DGPTAE",13,0) ;-- process record "RTN","DGPTAE",14,0) D ALLPR "RTN","DGPTAE",15,0) ;-- if errors "RTN","DGPTAE",16,0) D ERROR "RTN","DGPTAE",17,0) ;-- exit "RTN","DGPTAE",18,0) D EXIT "RTN","DGPTAE",19,0) Q "RTN","DGPTAE",20,0) ; "RTN","DGPTAE",21,0) ALLPR ;-- process all records types "RTN","DGPTAE",22,0) N ERROR,NODE,SEQ "RTN","DGPTAE",23,0) S ERROR=0 "RTN","DGPTAE",24,0) ; "RTN","DGPTAE",25,0) D FAC "RTN","DGPTAE",26,0) ; "RTN","DGPTAE",27,0) S NODE="" F S NODE=$O(^TMP("AEDIT",$J,NODE)) Q:NODE=""!(ERROR) D "RTN","DGPTAE",28,0) . S SEQ=0 F S SEQ=$O(^TMP("AEDIT",$J,NODE,SEQ)) Q:SEQ="" D RTE "RTN","DGPTAE",29,0) ; "RTN","DGPTAE",30,0) Q "RTN","DGPTAE",31,0) ; "RTN","DGPTAE",32,0) EXIT ;-- clean-up "RTN","DGPTAE",33,0) K ^TMP("AEDIT",$J),^TMP("AERROR",$J),^TMP("AD",$J) "RTN","DGPTAE",34,0) K DGPTDTS,DGPTPS,DGPTSSN,DGPTDTA,DGPTFAC,DGPTLN,DGPTFI,DGPTMI "RTN","DGPTAE",35,0) K DGPTSRA,DGPTTF,DGPTSRP,DGPTPOW,DGPTMRS,DGPTGEN,DGPTDOB,DGPTPOS1,DGPTPOS2,DGPTEXA,DGPTEXI,DGPTSTE,DGPTCTY,DGPTZIP,DGPTMTC,DGPTBY,DGPTINC "RTN","DGPTAE",36,0) K DGPTDDTD,DGPTDDS,DGPTDSP,DGPTDTY,DGPTDOP,DGPTDVA,DGPTDPD,DGPTDRF,DGPTDAS,DGPTDCP,DGPTDDXE,DGPTDDXO,DGPTDLR,DGPTDLC,DGPTDSC "RTN","DGPTAE",37,0) K DGPT70LG,DGPT70SU,DGPT70DR,DGPT70X4,DGPTDXV1,DGPTDXV2 "RTN","DGPTAE",38,0) K DGPTMSR,DGPTMSC,DGPTMLD,DGPTMPD,DGPTMSI,DGPTMD1,DGPTMD11,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMXX,DGPTMLR,DGPTMLC,DGPTMBS "RTN","DGPTAE",39,0) K DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR "RTN","DGPTAE",40,0) K DGACNT,DGPT7X51,DGPT7X52,DGPTADT,DGPTAGE,DGPTAL7,DGPTBYR,DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTDIAR,DGPTELP,DGPTFEF,DGPTFMDB,DGPTGEN1,DGPTL3,DGPTL4,DGPTMSX,DGPTS1,DGPTS2,DGPTSTTY,DGPTTY,DGPTXTTY,DGSCDT,DGPTPRAR,DGPTOPAR,DGSCDT,DGPTOC "RTN","DGPTAE",41,0) K DGFNUM,DGLAST,DGMVT,DGOUT,DGPTF,DGPTOPP,DGSCDT,DGSPEC,DGLAST,DGFNUM "RTN","DGPTAE",42,0) Q "RTN","DGPTAE",43,0) ; "RTN","DGPTAE",44,0) RTE ;route processing "RTN","DGPTAE",45,0) N DGFL2,I,J "RTN","DGPTAE",46,0) S DGFL2=0 F I=1:1:9 S:NODE=$P(DGPRS,U,I) DGFL2=1 Q:(DGFL2)!($P(DGPRS,U,I)']"") "RTN","DGPTAE",47,0) I 'DGFL2 S ERROR=101 Q "RTN","DGPTAE",48,0) Q:NODE="N701" "RTN","DGPTAE",49,0) ; "RTN","DGPTAE",50,0) D @("^DGPT"_$S($E(NODE,2)=4:"401",1:$E(NODE,2,4))) "RTN","DGPTAE",51,0) RTN ; "RTN","DGPTAE",52,0) Q "RTN","DGPTAE",53,0) ; "RTN","DGPTAE",54,0) PRES() ;-- check if required pieces are present "RTN","DGPTAE",55,0) N I,ERROR "RTN","DGPTAE",56,0) S ERROR=0 "RTN","DGPTAE",57,0) F I="N101","N501","N701" I '$D(^TMP("AEDIT",$J,I)) S ERROR=188 Q "RTN","DGPTAE",58,0) Q ERROR "RTN","DGPTAE",59,0) ; "RTN","DGPTAE",60,0) WRTERR(ERROR,NODE,SEQ) ;-- This function will write out errors to the ^TMP("AERROR" "RTN","DGPTAE",61,0) ; global. "RTN","DGPTAE",62,0) ; INPUT : ERROR - code of Austin's error "RTN","DGPTAE",63,0) ; NODE - node error occured on "RTN","DGPTAE",64,0) ; SEQ - sequence in ^TMP("AEDIT", "RTN","DGPTAE",65,0) ; "RTN","DGPTAE",66,0) I '$D(ERROR) G WRTQ "RTN","DGPTAE",67,0) S DGPTERP=DGPTERP+1,^TMP("AERROR",$J,SEQ,NODE,DGPTERP)=ERROR "RTN","DGPTAE",68,0) I DGPTERP>12 S DGPTEDFL=1 "RTN","DGPTAE",69,0) WRTQ Q "RTN","DGPTAE",70,0) ; "RTN","DGPTAE",71,0) FAC ;-- check facility id; get station type "RTN","DGPTAE",72,0) N SUFFIX,SOA,STATION,STTY "RTN","DGPTAE",73,0) S DGPTSTTY="",X=$G(^TMP("AEDIT",$J,"N101",1)),DGPTFAC=$E(X,25,30),SUFFIX=$E(X,29,30),SOA=$E(X,45,46) "RTN","DGPTAE",74,0) I SOA=" " D WRTERR(107) G FACQ "RTN","DGPTAE",75,0) I DGPTFAC'=" ",'DGPTFAC D WRTERR(108,"101") G FACQ "RTN","DGPTAE",76,0) I SUFFIX]"" I $D(^DIC(45.81,"D1",SUFFIX)) S DGPTSTTY=$O(^(SUFFIX,0)) S:DGPTSTTY DGPTSTTY=U_DGPTSTTY_U "RTN","DGPTAE",77,0) S X=$O(^DIC(45.1,"B",$E(X,45,46),0)) "RTN","DGPTAE",78,0) S STATION="",STTY=0 F S STTY=$O(^DIC(45.1,X,"ST",STTY)) Q:'STTY S STATION=STATION_"^"_STTY "RTN","DGPTAE",79,0) S STATION=STATION_"^" "RTN","DGPTAE",80,0) I $P(DGPTSTTY,U,2),STATION'[DGPTSTTY D WRTERR(135,"101") G FACQ "RTN","DGPTAE",81,0) S DGPTSTTY=STATION "RTN","DGPTAE",82,0) FACQ Q "RTN","DGPTAE",83,0) ; "RTN","DGPTAE",84,0) ERROR ;-- this routine will process the error detected during close-out "RTN","DGPTAE",85,0) G:'$D(^TMP("AERROR",$J)) ERRQ "RTN","DGPTAE",86,0) S DGERR=1 "RTN","DGPTAE",87,0) D EN^VALM("DGPT CLOSE-OUT ERROR") "RTN","DGPTAE",88,0) ERRQ Q "RTN","DGPTAE",89,0) ; "RTN","DGPTAEE2") 0^16^B13919194 "RTN","DGPTAEE2",1,0) DGPTAEE2 ;ALB/MTC - Austin Edits EAL Report Continued ; 14 DEC 92 "RTN","DGPTAEE2",2,0) ;;5.3;Registration;**8,338,415**;Aug 13, 1993 "RTN","DGPTAEE2",3,0) ; "RTN","DGPTAEE2",4,0) H601(REC) ;-- 601 error processing "RTN","DGPTAEE2",5,0) ; INPUT : REC - Record that contains the errors "RTN","DGPTAEE2",6,0) N X,X1 "RTN","DGPTAEE2",7,0) S X="PROC SSN ADM-DATE-TIME PROC-DATE-TIME SPC TYPE TRT" "RTN","DGPTAEE2",8,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",9,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(REC,31,32)_SP_$E(REC,33,34)_SP_$E(REC,35,36)_SP_$E(REC,37,40)_" " "RTN","DGPTAEE2",10,0) S X=X_$E(REC,41,42)_" "_$E(REC,43)_" "_$E(REC,44,46) "RTN","DGPTAEE2",11,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",12,0) S X="-----------PROCEDURE CODES-------------" "RTN","DGPTAEE2",13,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",14,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) "RTN","DGPTAEE2",15,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",16,0) D WRER^DGPTAEE "RTN","DGPTAEE2",17,0) Q "RTN","DGPTAEE2",18,0) ; "RTN","DGPTAEE2",19,0) H701(REC) ;-- 701 header "RTN","DGPTAEE2",20,0) ; INPUT : REC - Record that contains the errors "RTN","DGPTAEE2",21,0) N X,X1,X2 "RTN","DGPTAEE2",22,0) S X="DISP SSN ADM-DATE-TIME DIS-DATE-TIME SPC TYPE OP/RX VA/AUS PLACE RECVNG" "RTN","DGPTAEE2",23,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",24,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(REC,31,32)_SP_$E(REC,33,34)_SP_$E(REC,35,36)_SP_$E(REC,37,40)_SP "RTN","DGPTAEE2",25,0) S X=X_$E(REC,41,42)_" "_$E(REC,43)_" "_$E(REC,44)_" "_$E(REC,45)_" "_$E(REC,46)_" "_$E(REC,47,52) "RTN","DGPTAEE2",26,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",27,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) "RTN","DGPTAEE2",28,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",29,0) S X="ASIH XXXX C/P DXLS ODX CDR CODE PHY LOC %SC LI SI DRUG A4 A5" "RTN","DGPTAEE2",30,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",31,0) S X=$E(REC,53,55)_" "_$E(REC,56)_" "_$E(REC,57)_" "_$E(REC,58,64)_" "_$E(REC,65)_" "_$E(REC,66,71)_" "_$E(REC,72,73)_" "_$E(REC,74,76)_" "_$E(REC,77)_" "_$E(REC,78)_SP_$E(REC,79,82)_" "_$E(REC,83)_SP_$E(REC,84,87) "RTN","DGPTAEE2",32,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",33,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) "RTN","DGPTAEE2",34,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",35,0) S X="SC AO IR EC MST HNC ETH RACE " "RTN","DGPTAEE2",36,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",37,0) S X=$E(REC,88)_" "_$E(REC,89)_" "_$E(REC,90)_" "_$E(REC,91)_" "_$E(REC,92)_" "_$E(REC,93)_" "_$E(REC,94,95)_" "_$E(REC,96,107) "RTN","DGPTAEE2",38,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",39,0) D WRER^DGPTAEE "RTN","DGPTAEE2",40,0) Q "RTN","DGPTAEE2",41,0) ; "RTN","DGPTAEE2",42,0) H702(REC) ;-- 702 header "RTN","DGPTAEE2",43,0) ; INPUT : REC - Record that contains the errors "RTN","DGPTAEE2",44,0) N X,X1 "RTN","DGPTAEE2",45,0) S X="ADM SSN ADM-DATE-TIME DIS-DATE-TIME" "RTN","DGPTAEE2",46,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",47,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(REC,31,32)_SP_$E(REC,33,34)_SP_$E(REC,35,36)_SP_$E(REC,37,40) "RTN","DGPTAEE2",48,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",49,0) S X="----------------------------DIAGNOSTIC CODES----------------------------" "RTN","DGPTAEE2",50,0) S X=$E(REC,41,47)_SP_$E(REC,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(REC,97,103) "RTN","DGPTAEE2",51,0) S VALMCNT=VALMCNT+1,^TMP("AD",$J,VALMCNT,0)=X "RTN","DGPTAEE2",52,0) D WRER^DGPTAEE "RTN","DGPTAEE2",53,0) Q "RTN","DGPTAEE2",54,0) ; "RTN","DGPTF1") 0^11^B29748655 "RTN","DGPTF1",1,0) DGPTF1 ;ALB/JDS - PTF ENTRY/EDIT ; 10/4/01 10:12am "RTN","DGPTF1",2,0) ;;5.3;Registration;**69,114,195,397,342,415**;Aug 13, 1993 "RTN","DGPTF1",3,0) ; "RTN","DGPTF1",4,0) I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP "RTN","DGPTF1",5,0) S:'$D(IOST) IOST="C" S DGVI="""""",DGVO=DGVI I $D(IOST(0)) S:$D(^%ZIS(2,IOST(0),5)) I=^(5) S:$L($P(I,U,4)) DGVI=$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",6,0) WR G GET:'$D(A)!('$D(B)) W @IOF,HEAD,?72,@DGVI,"<101>",@DGVO "RTN","DGPTF1",7,0) FAC I $D(DGCST) W !?40,"Census Status: ",$P($P($P(^DD(45,6,0),"^",3),+DGCST_":",2),";") "RTN","DGPTF1",8,0) W !! S Z=1 D Z W " Facility: " S Z=$P(B(0),U,3)_$P(B(0),U,5),Z1=23 D Z1 "RTN","DGPTF1",9,0) MAR S Z=2 D Z W " Marit Stat: ",$S($D(^DIC(11,+$P(A(0),U,5),0)):$P(^(0),U,1),1:"") "RTN","DGPTF1",10,0) SA W !," Source of Adm: ",$S($D(^DIC(45.1,+B(101),0)):$P(^(0),U,5),1:"") "RTN","DGPTF1",11,0) N VADM D DEM^VADPT "RTN","DGPTF1",12,0) W ?39,"Ethnic: " D "RTN","DGPTF1",13,0) .I 'VADM(11) W "" Q "RTN","DGPTF1",14,0) .N NODE,NUM,ETHNIC,I "RTN","DGPTF1",15,0) .S I=0 "RTN","DGPTF1",16,0) .F NUM=0:1 S I=+$O(VADM(11,I)) Q:'I D "RTN","DGPTF1",17,0) ..S X=$$PTR2CODE^DGUTL4(+VADM(11,I),2,4) "RTN","DGPTF1",18,0) ..S ETHNIC=$S(X="":"?",1:X) "RTN","DGPTF1",19,0) ..S X=$$PTR2CODE^DGUTL4(+$G(VADM(11,I,1)),3,4) "RTN","DGPTF1",20,0) ..S ETHNIC=ETHNIC_$S(X="":"?",1:X) "RTN","DGPTF1",21,0) ..I NUM S ETHNIC=","_ETHNIC "RTN","DGPTF1",22,0) ..W ETHNIC "RTN","DGPTF1",23,0) W ?55,"Race: " D "RTN","DGPTF1",24,0) .I 'VADM(12) W "" Q "RTN","DGPTF1",25,0) .N NODE,NUM,RACE,I "RTN","DGPTF1",26,0) .S I=0 "RTN","DGPTF1",27,0) .F NUM=0:1 S I=+$O(VADM(12,I)) Q:'I D "RTN","DGPTF1",28,0) ..S X=$$PTR2CODE^DGUTL4(+VADM(12,I),1,4) "RTN","DGPTF1",29,0) ..S RACE=$S(X="":"?",1:X) "RTN","DGPTF1",30,0) ..S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,I,1)),3,4) "RTN","DGPTF1",31,0) ..S RACE=RACE_$S(X="":"?",1:X) "RTN","DGPTF1",32,0) ..I NUM S RACE=","_RACE "RTN","DGPTF1",33,0) ..W RACE "RTN","DGPTF1",34,0) K VADM "RTN","DGPTF1",35,0) W !," Source of Pay: " S L=";"_$P(^DD(45,22,0),U,3),L1=";"_$P(B(101),U,3)_":" W $P($P(L,L1,2),";",1) "RTN","DGPTF1",36,0) SEX S SEX=$P(A(0),U,2) W ?39," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:"") "RTN","DGPTF1",37,0) W !,"Trans Facility: ",$P(B(101),U,5)_$P(B(101),U,6) "RTN","DGPTF1",38,0) DOB S DOB=$P(A(0),U,3),Y=DOB D D^DGPTUTL W ?39," Date of Birth: ",Y "RTN","DGPTF1",39,0) CAT I DGPTFMT<2 W !," Cat of Ben: ",$S($D(^DIC(45.82,+$P(B(101),U,4),0)):$E($P(^(0),U,2),1,26),1:"") "RTN","DGPTF1",40,0) W:$X>50 ! "RTN","DGPTF1",41,0) W " Admit Elig: "_$S(+$P(B(101),U,8):$P($G(^DIC(8,+$P(B(101),U,8),0)),U),1:"UNKNOWN") W ?50,"SCI: " S L=";"_$P(^DD(2,57.4,0),U,3),L1=";"_$P(A(57),U,4)_":" W $P($P(L,L1,2),";",1) "RTN","DGPTF1",42,0) VIET W ! S Z=3 D Z W "Vietnam SRV: " S L=$P(A(.321),U,1),Z=$S(L="Y":"YES",L="N":"NO",1:"UNKNOWN"),Z1=28 D Z1 "RTN","DGPTF1",43,0) ST S Z=4 D Z W " State: ",$S($D(^DIC(5,+$P(A(.11),U,5),0)):$P(^(0),U,1),1:"") "RTN","DGPTF1",44,0) POW W !?11,"POW: " S L=$P(A(.52),U,5) W $S(L="Y":"YES",L="N":"NO",1:"UNKNOWN") "RTN","DGPTF1",45,0) ZIP W ?45,"Zip Code: ",$P(A(.11),U,6) "RTN","DGPTF1",46,0) POS W !,?6," POW SRV: " S L=$P(A(.52),U,6) W $E($S($D(^DIC(22,+L,0)):$P(^(0),U,1),1:""),1,23) "RTN","DGPTF1",47,0) COU W ?47,"County: ",$S($D(^DIC(5,+$P(A(.11),U,5),1,+$P(A(.11),U,7),0)):$P(^(0),U,1),1:"") "RTN","DGPTF1",48,0) ION W !," Ion Rad Exp: " S L=$P(A(.321),U,3) W $S(L="Y":"YES",L="N":"NO",1:"UNKNOWN") "RTN","DGPTF1",49,0) METH S L=$P(A(.321),U,12) W:L'="" ?38,"Exposure Method: ",$S(L="N":"Nagasaki/Hiroshima",L="T":"Nuclear Testing",L="B":"Both",1:"") "RTN","DGPTF1",50,0) AO W !," Agent Or exp: " S L=$P(A(.321),U,2) W $S(L="Y":"YES",L="N":"NO",1:"UNKNOWN") "RTN","DGPTF1",51,0) AOLOC S L=$P(A(.321),U,13) W:L'="" ?36,"Exposure Location: ",$S(L="V":"Vietnam",L="K":"Korean DMZ",1:"") "RTN","DGPTF1",52,0) MST W !," Claims MST: " S L=$P(A("MST"),U) W $S(L="Y":"YES",L="N":"NO",L="D":"DECLINED TO ANSWER",1:"UNKNOWN") ; added 6/17/98 for MST enhancement "RTN","DGPTF1",53,0) NTR W !," N/T Radium: " S L=A("NTR") W $S(L'="":L,1:"UNKNOWN") "RTN","DGPTF1",54,0) ; "RTN","DGPTF1",55,0) D EN^DGPTF4 K A,B Q:DGPR "RTN","DGPTF1",56,0) ; "RTN","DGPTF1",57,0) JUMP F I=$Y:1:20 W ! "RTN","DGPTF1",58,0) G 101^DGPTFJC:DGN S (DGZM0,DGZS0)=0 "RTN","DGPTF1",59,0) R "Enter: for ,",!,"1-7 to edit,'^N' for screen N, or '^' to abort: // ",X:DTIME S:'$T X="^",DGPTOUT="" "RTN","DGPTF1",60,0) G ^DGPTFM:X="",Q:X="^" "RTN","DGPTF1",61,0) I X?1"^".E S DGPTSCRN=101 G ^DGPTFJ "RTN","DGPTF1",62,0) G PR:X?.N&($L(X)>2) "RTN","DGPTF1",63,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","DGPTF1",64,0) I X'[",",1234567'[X G PR "RTN","DGPTF1",65,0) F I=1:1 S J=$P(X,",",I) Q:'J G:J<1!(J>7)!(J'?1N) PR "RTN","DGPTF1",66,0) I X<1!(X>7) G PR "RTN","DGPTF1",67,0) S (PT(1),PT(2))="",DGJUMP=X,DA=PTF,DIE="^DGPT(",DR="[DG101"_$E("F",DGPTFE)_"]" D ^DIE "RTN","DGPTF1",68,0) ;-- "RTN","DGPTF1",69,0) N DGPMCA,DGPMAN D PM^DGPTUTL "RTN","DGPTF1",70,0) I '$G(DGADM) S DGADM=+^DGPT(PTF,0) "RTN","DGPTF1",71,0) D MT^DGPTUTL "RTN","DGPTF1",72,0) GET F I=.32,.52,57,.521,0,.321,.11,.3 S A(I)="" S:$D(^DPT(DFN,I))&('DGST) A(I)=^(I) I DGN S:$D(^DGP(45.84,PTF,$S('I:10,1:I))) A(I)=^($S('I:10,1:I)) "RTN","DGPTF1",73,0) ; The following line added for MST enhancement 4/21/99 "RTN","DGPTF1",74,0) S A("MST")=$P($$GETSTAT^DGMSTAPI(DFN),U,2,5) "RTN","DGPTF1",75,0) K DGNTARR "RTN","DGPTF1",76,0) S A("NTR")=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"") "RTN","DGPTF1",77,0) K DGNTARR "RTN","DGPTF1",78,0) F I=0,101,70 S B(I)="" S:$D(^DGPT(PTF,I)) B(I)=^(I) "RTN","DGPTF1",79,0) S DGDD=+B(70),DGFC=+$P(B(0),U,3) "RTN","DGPTF1",80,0) K PT G DGPTF1 "RTN","DGPTF1",81,0) PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (screen # appears in upper right of screen '')",!," to continue on to the next screen or 1-7 to edit:" "RTN","DGPTF1",82,0) W !?10,"1-Facility, Source of admis, Payment, Transf facil, and Cat. of Benef",!?10,"2-Marital Stat, Race, Ethnicity, Sex, SCI, DOB" "RTN","DGPTF1",83,0) W !?10,"3-Agent Orange, Prisoner of War, Ionizing Radiation, MST, N/T Radium",!?10,"4-State, County, Zip code" "RTN","DGPTF1",84,0) W !?10,"5-Discharge date, type & specialty",!?10,"6-Outpatient treat & VA Auspices",!?10,"7-Receiving Facility, ASIH Days & C&P Status" "RTN","DGPTF1",85,0) W !,"You may also enter any combination of the above, separated by commas(ex:1,3,5)",! "RTN","DGPTF1",86,0) R !!,"Enter : ",X:DTIME G WR "RTN","DGPTF1",87,0) Q G Q^DGPTF "RTN","DGPTF1",88,0) Q "RTN","DGPTF1",89,0) Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO "RTN","DGPTF1",90,0) E W " " "RTN","DGPTF1",91,0) Q "RTN","DGPTF1",92,0) Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" " "RTN","DGPTF1",93,0) W Z "RTN","DGPTFTR") 0^17^B18207491 "RTN","DGPTFTR",1,0) DGPTFTR ;ALB/JDS - TRANSMISSION OF PTF ; 01 DEC 87 @0800 "RTN","DGPTFTR",2,0) ;;5.3;Registration;**37,415**;Aug 13, 1993 "RTN","DGPTFTR",3,0) ; "RTN","DGPTFTR",4,0) ENN L ^DGP(45.83):5 I '$T W !,"Already transmitting" Q "RTN","DGPTFTR",5,0) D CEN^DGPTUTL "RTN","DGPTFTR",6,0) I '$D(DGRTY) S Y=1 D RTY^DGPTUTL "RTN","DGPTFTR",7,0) D FDT^DGPTUTL S DGFMTDT=Y "RTN","DGPTFTR",8,0) ; "RTN","DGPTFTR",9,0) EN5 K DIC S DIC=45.83,DIC(0)="AMZEQ",DIC("A")="Enter Start Date: " "RTN","DGPTFTR",10,0) S DIC("S")="I $O(^DGP(45.83,+Y,""P"",0)) F DGX=0:0 S DGX=$O(^DGP(45.83,+Y,""P"",DGX)) Q:'DGX I '$P(^DGP(45.83,+Y,""P"",DGX,0),U,2),$D(^DGPT(DGX,0)),$D(^(70)),+^(70)>2901000,$P(^(0),U,11)=+DGRTY Q" "RTN","DGPTFTR",11,0) S D="ANT" D IX^DIC G ENQ1:X["^"!(X=""),EN5:Y'>0 "RTN","DGPTFTR",12,0) S DGSD=+Y(0),DIC(0)="EAMZQ",DIC("S")="I Y'0:+Y(0),1:DT) "RTN","DGPTFTR",15,0) ; -- 125 cols "RTN","DGPTFTR",16,0) S VATNAME="PTF125" D ^VATRAN I VATERR K VATNAME,VATERR,VAT L G ENQ "RTN","DGPTFTR",17,0) S DGFMT=2 D SCAN G:DGOUTX ENQ1 "RTN","DGPTFTR",18,0) ENQ D SCAN^DGPTFTR3 "RTN","DGPTFTR",19,0) ENQ1 L K DGACNT,DGXM,XMDUN,XMY,DGOUTX,DGSTCNT,DIC,DGX,DGRTY,DGRTY0,DGCN,DGCN0,DGPTFMT,DGFMT,DGFMTDT,DGLOGIC,VAT,VATERR,VATNAME,DGSD,DGED "RTN","DGPTFTR",20,0) Q "RTN","DGPTFTR",21,0) ; "RTN","DGPTFTR",22,0) SCAN K DGERR S DGPTFMT=2 D LOG S DGCNT=1,DGD=DGSD-.01,DGTR=0,DGID=1 "RTN","DGPTFTR",23,0) W !!,"Now transmitting 125 column ",$P(DGRTY0,U)," records..." "RTN","DGPTFTR",24,0) W !,"Includes records of " "RTN","DGPTFTR",25,0) ; "RTN","DGPTFTR",26,0) DAT D:DGCNT>1 XMIT S DGD=$O(^DGP(45.83,DGD)) "RTN","DGPTFTR",27,0) I DGD>0,DGD'>DGED D SETTRAN^DGPTUTL1 Q:DGOUTX "RTN","DGPTFTR",28,0) I DGD'>0!(DGD>DGED) D BULL^DGPTFTR3 G DATQ "RTN","DGPTFTR",29,0) S J=0 G PWR "RTN","DGPTFTR",30,0) DATQ Q "RTN","DGPTFTR",31,0) ; "RTN","DGPTFTR",32,0) PWR S P=J,J=$O(^DGP(45.83,DGD,"P",J)) G DAT:J'>0,PWR:$P(^(J,0),U,2) "RTN","DGPTFTR",33,0) I $D(^DGPT(J,0)),$P(^(0),U,11)'=+DGRTY G PWR "RTN","DGPTFTR",34,0) I $P(DGCN0,U,3)>DT,DGRTY=1 D CEN^DGPTFTR3 G PWR:'Y "RTN","DGPTFTR",35,0) S Y=$S($D(^DGPT(J,70)):+^(70),1:0) D FMT^DGPTUTL G PWR:DGPTFMT'=DGFMT "RTN","DGPTFTR",36,0) S T1=0,T2=9999999,Y=J,X=0 S:DGRTY=2 T2=+DGCN0_".9",T1=+$P(DGCN0,U,5) D LINES^DGPTFVC2 I (DGCNT+X)>VAT("F") S J=P G XMIT "RTN","DGPTFTR",37,0) K DICR S DGERR=0,DGSTCNT("P",J)=DGCNT "RTN","DGPTFTR",38,0) W !,$E($P(^DPT(+^DGPT(J,0),0),U),1,25),?27,"(#",J,")" S X=^DGPT(J,0) D WR^DGPTF "RTN","DGPTFTR",39,0) K ^TMP("AEDIT",$J),^TMP("AERROR",$J) S DGACNT=0 "RTN","DGPTFTR",40,0) I DGRTY=1 D COM "RTN","DGPTFTR",41,0) I DGRTY=2 S T2=+DGCN0_".9",T1=+$P(DGCN0,U,5),(PTF,DGCI)=J D COM1 "RTN","DGPTFTR",42,0) I DGERR D OPEN^DGPTFTR3 "RTN","DGPTFTR",43,0) K ^TMP("AEDIT",$J) "RTN","DGPTFTR",44,0) I 'DGERR W ?70," Okay" S DGTR=DGTR+1 G XMIT:DGCNT>VAT("F") "RTN","DGPTFTR",45,0) G PWR "RTN","DGPTFTR",46,0) Q "RTN","DGPTFTR",47,0) ; "RTN","DGPTFTR",48,0) XMIT K XMY D ROUTER "RTN","DGPTFTR",49,0) S XMZ=DGXMZ,^XMB(3.9,XMZ,2,0)="^3.92A^"_(DGCNT-1)_"^"_(DGCNT-1)_"^"_DT,DGJ=J "RTN","DGPTFTR",50,0) S XMDUZ=.5,XMDUN=$P(^VA(200,DUZ,0),U) D ENT1^XMD "RTN","DGPTFTR",51,0) W !,"Transmission Queued" S DGIDN(DGID)=XMZ "RTN","DGPTFTR",52,0) F DGK=0:0 S DGK=$O(DGSTCNT("P",DGK)) Q:DGK'>0 D REC "RTN","DGPTFTR",53,0) K DGK S DGCNT=1,DGID=DGID+1,J=DGJ Q:J'>0 D SETTRAN^DGPTUTL1 G:'DGOUTX PWR "RTN","DGPTFTR",54,0) Q "RTN","DGPTFTR",55,0) ; "RTN","DGPTFTR",56,0) REC ; "RTN","DGPTFTR",57,0) S DGSENFLG="" "RTN","DGPTFTR",58,0) S DIE="^DGP(45.83,",DA=DGD,DR="10///"_DGK,DR(2,45.831)="1///TODAY;2///"_XMZ D ^DIE K DA,DR,DIE "RTN","DGPTFTR",59,0) S DIE="^DGPT(",DR="6///3",DA=DGK D ^DIE K DA,DR,DIE "RTN","DGPTFTR",60,0) K DGSENFLG "RTN","DGPTFTR",61,0) Q "RTN","DGPTFTR",62,0) ; "RTN","DGPTFTR",63,0) COM S T1=0,T2=9999999 S:'$D(PTF) PTF=J S:PTF'=J PTF=J "RTN","DGPTFTR",64,0) COM1 F K=0,70,101,"401P" S @("DG"_K)=$S($D(^DGPT(J,K)):^(K),1:"") "RTN","DGPTFTR",65,0) F K=10,.11,.3,.32,.321,.52,57 S @("DG"_$S(K[".":$E(K,2,99),1:K))=$S($D(^DGP(45.84,J,K)):^(K),$D(^DPT(+^DGPT(J,0),$S(K'=10:K,1:0))):$S(K'=10:^(K),1:^(0)),1:"") "RTN","DGPTFTR",66,0) F K=.02,.06 M @("DG"_$S(K[".":$E(K,2,99),1:K))=^DPT(+^DGPT(J,0),K) "RTN","DGPTFTR",67,0) D ^DGPTFTR0:DGPTFMT=1,^DGPTR0:DGPTFMT=2 "RTN","DGPTFTR",68,0) ; "RTN","DGPTFTR",69,0) Q L F K=0,10,701,"401P",101,11,3,32,41,52,57,70,321,502,702,"02","06" K @("DG"_K) "RTN","DGPTFTR",70,0) K DGCDR,DGT,DIC,DGADM,DGAO,DGDOB,DGHEAD,DGJ,DGK,DGL,DGM,DGNAM,DGNT,DGO,DGSSN,DGSUD,DGSUR,DGTD,DGX,DGXLS,E,ERR,F,G,H,I,K,L,T,W,Z,DGPROC,DGPROCD ;** NOTE: do not kill variables needed by PTF load/edit option!!! "RTN","DGPTFTR",71,0) I $D(DGERR),DGERR<1 D ^DGPTFVC1 D:'T1 ^DGPTFVC3 "RTN","DGPTFTR",72,0) I $D(DGERR),DGERR<1 D EN^DGPTFVC2 "RTN","DGPTFTR",73,0) Q "RTN","DGPTFTR",74,0) ; "RTN","DGPTFTR",75,0) LOG ;called from PRINT+1^DGPTF2,CLS+1^DGPTF2,EN^DGPTFVC "RTN","DGPTFTR",76,0) D LOG^DGPTFTR1:DGPTFMT=1,LOG^DGPTR1:DGPTFMT=2,COM:$D(DGERR) "RTN","DGPTFTR",77,0) Q "RTN","DGPTFTR",78,0) ; "RTN","DGPTFTR",79,0) ;-- check for real queue if census should be removed for national rel "RTN","DGPTFTR",80,0) ROUTER S XMDUZ=.5 F DGSDI=0:0 S DGSDI=$O(VAT(DGSDI)) Q:'DGSDI S X=VAT(DGSDI),XMN=0,XMDF="" D INST^XMA21 K XMN,XMDF "RTN","DGPTFTR",81,0) S XMY(DUZ)="" "RTN","DGPTFTR",82,0) Q "RTN","DGPTFVC1") 0^18^B34530107 "RTN","DGPTFVC1",1,0) DGPTFVC1 ;ALB/AS - Expanded PTF Close-Out Edits ; Jul 20 88 @ 0900 "RTN","DGPTFVC1",2,0) ;;5.3;Registration;**52,58,79,114,164,400,342,466,415**;Aug 13, 1993 "RTN","DGPTFVC1",3,0) ;Called from Q+2^DGPTFTR. Variable must be passed in: PTF "RTN","DGPTFVC1",4,0) ;Variable returned: DGERR. DGERR <-- 1 if record fails to pass a check; DGERR <-- "" if record passes all checks "RTN","DGPTFVC1",5,0) ; "RTN","DGPTFVC1",6,0) Q:'$D(PTF) "RTN","DGPTFVC1",7,0) S DGERR="",DGV(701)=$S($D(^DGPT(PTF,70)):^(70),1:""),DGV(101)=^(0),DGSUFFIX=$P(DGV(101),"^",5),DGV("FEE")=$P(DGV(101),"^",4),DFN=$P(DGV(101),"^",1) "RTN","DGPTFVC1",8,0) ; "RTN","DGPTFVC1",9,0) I $P(DGV(101),"^",2)>2820700 D AO "RTN","DGPTFVC1",10,0) ; "RTN","DGPTFVC1",11,0) I DGRTY=1,DGV("FEE") D MT "RTN","DGPTFVC1",12,0) ; "RTN","DGPTFVC1",13,0) I 'DGV("FEE"),$P(DGV(101),"^",10)="U",'DGV(701)!(+DGV(701)>2890700) S DGERR=1 W !,"101 MEANS TEST",?23," value 'U' - not valid for discharges as of 7/1/1989",!?42,"per MAS VACO policy" "RTN","DGPTFVC1",14,0) ; "RTN","DGPTFVC1",15,0) I $D(^DPT(DFN,57)),$P(^(57),"^",4)>0 S S0=$P(^(57),"^",4),DGDX=$S(S0=1!(S0=3):"344.1",1:"344.0"),DGSCI="" F DGX=0:0 S DGX=$O(^DGPT(PTF,"M",DGX)) Q:DGX'>0 S DGNODE=^(DGX,0),DGSCI="" D SCI "RTN","DGPTFVC1",16,0) ; "RTN","DGPTFVC1",17,0) S DGDP="",DGDISPO=$P(DGV(701),"^",6),DGRECSUF=$P(DGV(701),"^",13) "RTN","DGPTFVC1",18,0) I DGRTY=1 D "RTN","DGPTFVC1",19,0) .S DGSTATYP=$S(DGDISPO=12!(DGDISPO=13):30,DGDISPO=10:42,DGDISPO=8:40,1:"") "RTN","DGPTFVC1",20,0) .I DGSTATYP]"" D "RTN","DGPTFVC1",21,0) ..D NUMACT^DGPTSUF(DGSTATYP) "RTN","DGPTFVC1",22,0) ..I DGANUM>0 F I=1:1:DGANUM I DGSUFFIX=DGSUFNAM(I) D "RTN","DGPTFVC1",23,0) ...I DGDISPO'=8 I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP "RTN","DGPTFVC1",24,0) ...I DGDISPO=8 N DGANUM,DGSUFNAM D NUMACT^DGPTSUF(42) I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP "RTN","DGPTFVC1",25,0) .K DGANUM,DGSTATYP,DGSUFNAM,I "RTN","DGPTFVC1",26,0) ; "RTN","DGPTFVC1",27,0) I DGRTY=1 S %=$P(DGV(701),"^",3) I %=4!(%=6)!(%=7) S DGDP="" D OP I $P(DGV(701),"^",5)=1 S DGERR=1 W !,"701 VA AUSPICES",?23," value inconsistent for discharge" "RTN","DGPTFVC1",28,0) ; "RTN","DGPTFVC1",29,0) ;I 'DGV("FEE") S %=$P(^DPT(DFN,0),"^",6),%=$S($D(^DIC(10,+%,0)):$P(^(0),"^",2),1:"") I '%!(%>7) S DGERR=1 W !,"701 RACE",?23," value " W:%']"" "blank" I %]"" W %," (invalid code)" "RTN","DGPTFVC1",30,0) ; "RTN","DGPTFVC1",31,0) ;If PRRTP treating specialty, must have valid PRRTP suffix "RTN","DGPTFVC1",32,0) ;Fee records would not contain PRRTP specialties "RTN","DGPTFVC1",33,0) I 'DGV("FEE"),"^25^26^27^28^29^38^39^"[(U_$P(DGV(701),U,2)_U) D "RTN","DGPTFVC1",34,0) .I DGSUFFIX'="PA",(DGSUFFIX'="PB"),(DGSUFFIX'="PC"),(DGSUFFIX'="PD") D "RTN","DGPTFVC1",35,0) ..S DGERR=1 "RTN","DGPTFVC1",36,0) ..W !,"101 SUFFIX",?23,"value must be set to a valid PRRTP suffix." "RTN","DGPTFVC1",37,0) ; "RTN","DGPTFVC1",38,0) D RACETHNC "RTN","DGPTFVC1",39,0) K DGDISPO,DGRECSUF,DGV,DGDP,DGDX,DGSCI,DGSUFFIX,DGNODE,DGX,%,S0,I,X "RTN","DGPTFVC1",40,0) I DGERR H 4 "RTN","DGPTFVC1",41,0) Q "RTN","DGPTFVC1",42,0) ; "RTN","DGPTFVC1",43,0) SCI F X=5:1:15 I X#10 S:$E($P($G(^ICD9(+$P(DGNODE,"^",X),0)),"^"),1,5)=DGDX DGSCI=1 Q:DGSCI "RTN","DGPTFVC1",44,0) I 'DGSCI S DGERR=1,%=$P(DGNODE,"^",10),X=$TR($$FMTE^XLFDT(%,"5DF")," ","0") W !,"501 ",X," SCI of ",S0,?23," requires an ICD Diagnosis code beginning with",!?12," or equal to ",DGDX "RTN","DGPTFVC1",45,0) Q "RTN","DGPTFVC1",46,0) ; "RTN","DGPTFVC1",47,0) MT S DGVMT=$P(DGV(101),"^",10),DGX=999 G DGX:DGVMT']"" I +$P(DGV(101),"^",2)<2860700!(DGSUFFIX="BU") S DGX="X" G DGX "RTN","DGPTFVC1",48,0) ;S DGZEC=$S($D(^DPT(DFN,.36)):$P(^(.36),U,1),1:""),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DGX "RTN","DGPTFVC1",49,0) S DGZEC=$P($G(^DGPT(PTF,101)),U,8),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DGX "RTN","DGPTFVC1",50,0) S DGT=$P(DGV(701),".") G AS:'$O(^DGMT(408.31,"AD",1,DFN,0)) S DGZ1=$$LST^DGMTU(DFN,DGT) K:DGZ1']"" DGZ1 "RTN","DGPTFVC1",51,0) I DGVMT="X" K DGX,DGVMT Q "RTN","DGPTFVC1",52,0) S DGX=$S('$D(DGZ1):"U",1:$P(DGZ1,U,4)) "RTN","DGPTFVC1",53,0) ; Determine if the Pending Adjudication is for MT(C) or GMT(G) "RTN","DGPTFVC1",54,0) I DGX="P" D G DGX "RTN","DGPTFVC1",55,0) . I '+$P($G(DGZ1),U) S DGX="U" Q "RTN","DGPTFVC1",56,0) . S DGX=$$PA^DGMTUTL($P(DGZ1,U)),DGX=$S('$D(DGX):"U",DGX="MT":"C",DGX="GMT":"G",1:"U") "RTN","DGPTFVC1",57,0) S DGX=$S(DGX="A":"AN","BCGN"[DGX:DGX,1:"U") G DGX:DGX'="N" "RTN","DGPTFVC1",58,0) AS S DGZ=$S($D(^DPT(DFN,.321)):^(.321),1:0) I $P(DGZ,U,2)="Y"!($P(DGZ,U,3)="Y") S DGX="AS" G DGX "RTN","DGPTFVC1",59,0) S DGZ=$S($D(^DPT(DFN,.322)):^(.322),1:0) I $P(DGZ,U,13)="Y" S DGX="AS" G DGX "RTN","DGPTFVC1",60,0) N DGNTARR S DGZ=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("NTR"),1:"") I $P(DGZ,U)="Y" S DGX="AS" G DGX "RTN","DGPTFVC1",61,0) S DGZ=$$GETSTAT^DGMSTAPI(DFN) I $P(DGZ,U,2)="Y" S DGX="AS" G DGX "RTN","DGPTFVC1",62,0) I $P(DGZEC,U,5)="Y",$P(DGZEC,U,4)<4,"^2^15^"'[(U_$P(DGZEC,U,9)_U) S DGX="AS" G DGX "RTN","DGPTFVC1",63,0) S DGX="AN" "RTN","DGPTFVC1",64,0) DGX I DGVMT'=DGX S DGERR=1 W !,"101 ","MEANS TEST",?23," value ",DGVMT,$S(DGVMT']"":"blank",DGVMT="X":" only for admissions prior to 7/1/86 or domicilliary use",1:" inconsistent with eligibility data") "RTN","DGPTFVC1",65,0) K DGZEC,DGZ,DGZ1,DGT,DGX,DGVMT Q "RTN","DGPTFVC1",66,0) ; "RTN","DGPTFVC1",67,0) DP I $P(DGV(701),"^",3)'=5 S DGERR=1 W !,"701 ",$E("TYPE OF DISPOSITION",1,18),?23," value inconsistent for discharge" "RTN","DGPTFVC1",68,0) OP I $P(DGV(701),"^",4)=1 S DGERR=1 W !,"701 ",$E("OUTPATIENT TREATMENT",1,18),?23," value inconsistent for discharge" Q:DGDP="" "RTN","DGPTFVC1",69,0) I $P(DGV(701),"^",5)=2 S DGERR=1 W !,"701 VA AUSPICES",?23," value inconsistent for discharge" "RTN","DGPTFVC1",70,0) Q "RTN","DGPTFVC1",71,0) ; "RTN","DGPTFVC1",72,0) AO I DGPTFMT<2 D Q "RTN","DGPTFVC1",73,0) .S %=$S($D(^DGPT(PTF,101)):$P(^(101),"^",4),1:"") "RTN","DGPTFVC1",74,0) .S %=$S($D(^DIC(45.82,+%,0)):$P(^(0),"^",1),1:"") "RTN","DGPTFVC1",75,0) .S I=$S($D(^DPT(DFN,.321)):^(.321),1:"") "RTN","DGPTFVC1",76,0) .S:$P(I,"^",2)="Y"&(%'=6) DGERR=1,DGV("E")=1 "RTN","DGPTFVC1",77,0) .W:$D(DGV("E")) !,"101 AGENT ORANGE",?23," value ",$S(DGV("E"):"can only be used with COB of '6'",1:"is inconsistent with Vietnam Service and/or COB") "RTN","DGPTFVC1",78,0) ; "RTN","DGPTFVC1",79,0) N AO,AOL,TMP "RTN","DGPTFVC1",80,0) S TMP=$G(^DPT(DFN,.321)) "RTN","DGPTFVC1",81,0) S AO=$S($P(TMP,"^",2)="Y":1,1:0) "RTN","DGPTFVC1",82,0) S AOL=$P(TMP,"^",13) "RTN","DGPTFVC1",83,0) Q:('AO) "RTN","DGPTFVC1",84,0) Q:(AOL'="") "RTN","DGPTFVC1",85,0) S DGERR=1,DGV("E")=1 "RTN","DGPTFVC1",86,0) W !,"101 AGENT ORANGE LOCATION",?23,"value required if exposure to Agent Orange claimed" "RTN","DGPTFVC1",87,0) Q "RTN","DGPTFVC1",88,0) RACETHNC ;Race and ethnicity check "RTN","DGPTFVC1",89,0) ;Ensure that a value for ethnicity and at least one race is on file. "RTN","DGPTFVC1",90,0) ;Ensure all active race/ethnicity values have a valid PTF value and an "RTN","DGPTFVC1",91,0) ;associated collection method. Ensure all collection methods have a "RTN","DGPTFVC1",92,0) ;valid PTF value. Ignore race/ethicity entries that are inactive or "RTN","DGPTFVC1",93,0) ;invalid pointers. Note: PTF sends first active ethnicity and first "RTN","DGPTFVC1",94,0) ;six active races. "RTN","DGPTFVC1",95,0) N REF,IEN,TYPE,TEXT,PTRVAL,PTRMTHD,NUM,MAX "RTN","DGPTFVC1",96,0) N VALIDVAL,VALIDMTH,VALUE,VADM "RTN","DGPTFVC1",97,0) D DEM^VADPT "RTN","DGPTFVC1",98,0) F REF=11,12 D "RTN","DGPTFVC1",99,0) .I REF=12 D "RTN","DGPTFVC1",100,0) ..S MAX=6 "RTN","DGPTFVC1",101,0) ..S TYPE=1 "RTN","DGPTFVC1",102,0) ..S VALIDVAL=",3,7,8,9,A,B,C," "RTN","DGPTFVC1",103,0) ..S VALIDMTH=",S,P,O,U," "RTN","DGPTFVC1",104,0) ..S TEXT="RACE" "RTN","DGPTFVC1",105,0) .I REF=11 D "RTN","DGPTFVC1",106,0) ..S MAX=1 "RTN","DGPTFVC1",107,0) ..S TYPE=2 "RTN","DGPTFVC1",108,0) ..S TEXT="ETHNICITY" "RTN","DGPTFVC1",109,0) ..S VALIDVAL=",H,N,D,U," "RTN","DGPTFVC1",110,0) ..S VALIDMTH=",S,P,O,U," "RTN","DGPTFVC1",111,0) .S NUM=1 "RTN","DGPTFVC1",112,0) .S IEN=0 "RTN","DGPTFVC1",113,0) .F S IEN=+$O(VADM(REF,IEN)) Q:'IEN D Q:NUM>MAX "RTN","DGPTFVC1",114,0) ..S PTRVAL=+VADM(REF,IEN) "RTN","DGPTFVC1",115,0) ..S PTRMTHD=+$G(VADM(REF,IEN,1)) "RTN","DGPTFVC1",116,0) ..Q:'PTRVAL "RTN","DGPTFVC1",117,0) ..Q:$$INACTIVE^DGUTL4(PTRVAL,TYPE) "RTN","DGPTFVC1",118,0) ..S NUM=NUM+1 "RTN","DGPTFVC1",119,0) ..S VALUE=$$PTR2CODE^DGUTL4(PTRVAL,TYPE,4) "RTN","DGPTFVC1",120,0) ..I (VALUE="")!(VALIDVAL'[VALUE) D Q "RTN","DGPTFVC1",121,0) ...W !,"701 ",TEXT,?23,"missing/invalid xmit value" "RTN","DGPTFVC1",122,0) ...S DGERR=1 "RTN","DGPTFVC1",123,0) ..I ('PTRMTHD) D Q "RTN","DGPTFVC1",124,0) ...W !,"701 ",TEXT,?23,"method of collection missing/invalid" "RTN","DGPTFVC1",125,0) ...S DGERR=1 "RTN","DGPTFVC1",126,0) ..S VALUE=$$PTR2CODE^DGUTL4(PTRMTHD,3,4) "RTN","DGPTFVC1",127,0) ..I (VALUE="")!(VALIDMTH'[VALUE) D Q "RTN","DGPTFVC1",128,0) ...W !,"701 ",TEXT,?23,"missing/invalid xmit value for method of collection" "RTN","DGPTFVC1",129,0) ...S DGERR=1 "RTN","DGPTFVC1",130,0) Q "RTN","DGPTR1") 0^19^B24526056 "RTN","DGPTR1",1,0) DGPTR1 ;ALB/MTC - PTF VERIFICATION ; 01 MAR 91 @0800 "RTN","DGPTR1",2,0) ;;5.3;Registration;**58,247,338,342,423,415**;Aug 13, 1993 "RTN","DGPTR1",3,0) START S T=$E(Y,2,3),T=$S(T=40&($E(Y,28)="P"):"P40",1:T),ERR=$P($T(@("T"_T)),";;",2,999),W=$P($T(@(T)),";;",2,999),F=31 D L "RTN","DGPTR1",4,0) I T=70 S ERR=$P($T(T701),";;",2,999),W=$P($T(701),";;",2,999),F=72 D L "RTN","DGPTR1",5,0) D @("D"_T) Q "RTN","DGPTR1",6,0) K DGFILL "RTN","DGPTR1",7,0) Q "RTN","DGPTR1",8,0) ; "RTN","DGPTR1",9,0) L F H=1:1 S DGO=$P(W,U,H) Q:'DGO F Z=1:1:$P(DGO,";",3) S DGL=$P(DGLOGIC,U,+DGO),X=$E(Y,F) D @("ERR:"_DGL) S F=F+1 "RTN","DGPTR1",10,0) Q "RTN","DGPTR1",11,0) ; "RTN","DGPTR1",12,0) T10 ;;1:NAME^2:SOURCE OF ADM^3:TRANS FAC.^4:SOURCE OF PAY^5:POW^6:MARITAL ST^7:SEX^8:DOB^9:POS^10:VIETNAM^11:ION RADIATION^12:RESIDENCE^13:MEANS TEST^14:INCOME^15:MST "RTN","DGPTR1",13,0) ; "RTN","DGPTR1",14,0) T70 ;;1:DT OF DISP.^2:DISCH BD SEC^3:TYPE OF DIS^4:OUT TREAT^5:VA AUS^6:PL OF DIS^7:REC FAC^8:ASIH DAYS^9:NOT USED^10:C&P STAT^11:DXLS^12:ONLY DX^13:PHY CDR "RTN","DGPTR1",15,0) ;T701 is part 2 of T70 "RTN","DGPTR1",16,0) T701 ;;1:PHY SPEC^2:%SC^3:LEGION^4:SUICIDE^5:DRUG^6:AXIS-IV^7:AXIS-V^8:SC^9:EXP^10:MST^11:HNC^12:ETHNICITY^13:RACE "RTN","DGPTR1",17,0) ; "RTN","DGPTR1",18,0) T50 ;;1:DT OF MVMT^2:LOSING BD SEC CDR^3:LOSING BD SEC^4:LEAVE DAYS^5:PASS DAYS^6:SCI^7:DIAG^8:DOCTOR'S SSN^9:PHY CDR^10:PHY SPEC^11:DISCHARGE STAT^^^^^16:LEGION^17:SUICIDE^18:DRUG^19:AXIS-IV^20:AXIS-V^21:SC^22:EXP^23:MST^24:HNC "RTN","DGPTR1",19,0) ; "RTN","DGPTR1",20,0) T53 ;;1:DATE OF PHYSICAL MOVEMENT^2:LOSING PHYSICAL CDR^3:LOSING PHYSICAL SPECIALTY^4:TR SPECIALTY CDR^5:TR SPECIALTY^6:LEAVE DAYS^7:PASS DAYS^8:DOCTOR'S SSN (NOT USED) "RTN","DGPTR1",21,0) ; "RTN","DGPTR1",22,0) T40 ;;1:DATE OF SURGERY^2:SURG SPEC.^3:CAT CHIEF SURGEON^4:CAT FIRST ASS^5:ANEST. TECH.^6:SOURCE OF PAY^7:OP CODE^8:DOCTOR'S SSN (NOT USED)^^^^^13:TRANSPLANT STATUS "RTN","DGPTR1",23,0) ; "RTN","DGPTR1",24,0) TP40 ;;1:OP CODE "RTN","DGPTR1",25,0) ; "RTN","DGPTR1",26,0) T60 ;;1:DATE OF PROCEDURE^2:LOSING BD SEC^3:DIALYSIS TYPE^4:NUMBER OF TREATMENTS^5:PROCEDURE CODE "RTN","DGPTR1",27,0) ; "RTN","DGPTR1",28,0) LOGIC ;;X'?.N^X'?.A^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'?.N)&('$P(DG0,U,4))^((T1)&(X'=" "))!(('T1)&(X'?.N)&('$P(DG0,U,4))) "RTN","DGPTR1",29,0) ; "RTN","DGPTR1",30,0) ; edit check# ; edit field ; # x check preformed ; display error name # "RTN","DGPTR1",31,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^1;11;5;12^7;11;5;12^2;12;1;13^6;;1;13^1;;6;14^2;;1;15^4;10;1;16^3;;37; "RTN","DGPTR1",32,0) ; "RTN","DGPTR1",33,0) 70 ;;1;1;10;1^1;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;11^6;;3;11^10;11;1;11^6;;1;12^15;;6;13 "RTN","DGPTR1",34,0) ;701 is part 2 of 70 "RTN","DGPTR1",35,0) 701 ;;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;11^13;12;2;12^13;13;12;13^3;;18; "RTN","DGPTR1",36,0) ; "RTN","DGPTR1",37,0) 50 ;;1;1;10;1^1;;6;2^1;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;10^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","DGPTR1",38,0) ; "RTN","DGPTR1",39,0) 53 ;;1;;10;1^1;;6;2^1;;2;3^1;;6;4^1;;2;5^1;;3;6^1;;3;7^3;;9;8^3;;54; "RTN","DGPTR1",40,0) ; "RTN","DGPTR1",41,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;;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",42,0) ; "RTN","DGPTR1",43,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","DGPTR1",44,0) ; "RTN","DGPTR1",45,0) 60 ;;1;1;10;1^1;2;2;2^4;3;1;3^4;4;3;4^11;5;3;5^6;;32;5^3;;44 "RTN","DGPTR1",46,0) ; "RTN","DGPTR1",47,0) ERR S DGERR=1 "RTN","DGPTR1",48,0) W !,T,$S(T["H":" ",1:$E(Y,4))," " "RTN","DGPTR1",49,0) W:"45"[$E(T,1) $E(Y,31,32),"-",$E(Y,33,34),"-",$E(Y,35,36),"@",$E(Y,37,40) "RTN","DGPTR1",50,0) W ?25,$P($P(ERR,U,$P(DGO,";",4)),":",2),?40,"COL.",F," VALUE: ",$S($E(Y,F)=" ":"BLANK",1:$E(Y,F)) "RTN","DGPTR1",51,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","DGPTR1",52,0) Q "RTN","DGPTR1",53,0) ; "RTN","DGPTR1",54,0) D10 I $E(Y,66)="Z" S (F,H)=68,W="11;10;1;10" D L "RTN","DGPTR1",55,0) I $P(^DGPT(J,0),"^",4),$P(^(0),"^",10)="U",$D(^DGPT(J,70)),+^(70)>2890700 S F=79,DGO="2;12;1;12" D ERR "RTN","DGPTR1",56,0) Q "RTN","DGPTR1",57,0) ; "RTN","DGPTR1",58,0) D40 Q "RTN","DGPTR1",59,0) DP40 Q "RTN","DGPTR1",60,0) D70 I "467"'[$E(Y,43) S F=44,W="4;4;1;4^1;5;1;5^11;6;1;6" D L "RTN","DGPTR1",61,0) Q "RTN","DGPTR1",62,0) D50 I "A0"[$P(DG0,U,5)!("A4"[$P(DG0,U,5))!('$D(^DGPT(J,70))) S W="11;6;1;6",F=55 D L "RTN","DGPTR1",63,0) I $D(^DGPT(J,70)),$S(T1:1,1:+^(70)>2871000) S W="11;6;1;6",F=55 D L "RTN","DGPTR1",64,0) I $E(Y,4)=1 S W="9;7;1;7",F=56 D L "RTN","DGPTR1",65,0) I I=1,'T1 S W="1;11;1;11",F=108 D L "RTN","DGPTR1",66,0) Q "RTN","DGPTR1",67,0) D53 Q "RTN","DGPTR1",68,0) D60 I $E(Y,43) S F=44,W="1;4;3;4" D L "RTN","DGPTR1",69,0) Q "RTN","DGPTR1",70,0) HEAD S ERR="1:SSN^2:ADMISSION 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,DGLOGIC=$P($T(LOGIC),";;",2),T="HEADER" "RTN","DGPTR1",71,0) D L "RTN","DGPTR1",72,0) Q "RTN","DGPTR1",73,0) LOG S DGLOGIC=$P($T(LOGIC),";;",2) "RTN","DGPTR1",74,0) Q "RTN","DGPTR1",75,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",76,0) S ERR=$P($T(T701),";;",2),W=$P($T(701),";;",2,999),F=72 D L "RTN","DGPTR1",77,0) Q "RTN","DGPTR4") 0^20^B14594444 "RTN","DGPTR4",1,0) DGPTR4 ;ALB/JDS/MJK/MTC - ALB/BOK PTF TRANSMISSION ; 01 DEC 87 @0800 "RTN","DGPTR4",2,0) ;;5.3;Registration;**338,423,415**;Aug 13, 1993 "RTN","DGPTR4",3,0) 701 ; -- setup 701 transaction "RTN","DGPTR4",4,0) S Y=$S(T1:"C",1:"N")_"701"_DGHEAD,DGDDX=$P(+DG70,".")_" ",Y=Y_$E(DGDDX,4,5)_$E(DGDDX,6,7)_$E(DGDDX,2,3)_$E($P(+DG70,".",2)_"0000",1,4) "RTN","DGPTR4",5,0) S X=DG70,(L,Z)=2 D ENTER0 K DGDDX "RTN","DGPTR4",6,0) S X=DG70 I "467"[($P(X,U,3)\1) S Y=Y_$P(X,U,3)_" " G J "RTN","DGPTR4",7,0) S L=1 F Z=3:1:5 D ENTER "RTN","DGPTR4",8,0) S Y=Y_$S($D(^DIC(45.6,+$P(X,U,6),0)):$P(^(0),U,2),1:" "),L=3,Z=12 D ENTER S Y=Y_$E($P(X,U,13)_" ",1,3) "RTN","DGPTR4",9,0) J S L=3,Z=8 D ENTER0 "RTN","DGPTR4",10,0) S Y=Y_"X"_$J($P(DG70,U,9),1) "RTN","DGPTR4",11,0) S DGXLS=$S($D(^ICD9(+$P(DG70,U,10),0)):$P(^(0),U,1),1:""),Y=Y_$S(DGXLS[".":$J($P(DGXLS,".",1),3)_$E($P(DGXLS,".",2)_" ",1,3),1:$J(DGXLS,6))_" " "RTN","DGPTR4",12,0) S L=$P(DG70,U,16,24) S DG702="" F K=1:1:9 I $D(^ICD9(+$P(L,U,K),0)) S DG702=DG702_$P(^(0),U,1)_U "RTN","DGPTR4",13,0) S Y=Y_$S(DG702']"":"X",1:" ") "RTN","DGPTR4",14,0) ; -- get phy cdr @ d/c "RTN","DGPTR4",15,0) S X="",Z=+$O(^DGPT(J,535,"AM",DG70-.0000001)) I $D(^DGPT(J,535,+$O(^(Z,0)),0)) S X=^(0) "RTN","DGPTR4",16,0) ; -- set phy cdr "RTN","DGPTR4",17,0) S Z=$P(X,U,16) D CDR "RTN","DGPTR4",18,0) ; -- set phy spec "RTN","DGPTR4",19,0) S L=2,Z=2 D ENTER0 "RTN","DGPTR4",20,0) S X=$S($P(DG3,U)="Y":$$RTEN($P(DG3,U,2)),1:"0"),L=3,Z=1 D ENTER0 "RTN","DGPTR4",21,0) ;-- additional ptf questions "RTN","DGPTR4",22,0) S DGAUX=$S($D(^DGPT(J,300)):^(300),1:"") "RTN","DGPTR4",23,0) D ADDQUES "RTN","DGPTR4",24,0) K DGAUX,DGDRUG "RTN","DGPTR4",25,0) ;-- sc,ao,ir,ec questions "RTN","DGPTR4",26,0) S X=DG70 "RTN","DGPTR4",27,0) ;-- sc "RTN","DGPTR4",28,0) S Y=Y_$E($P(DG70,U,25)_" ") "RTN","DGPTR4",29,0) ;-- ao "RTN","DGPTR4",30,0) S Y=Y_$E($P(DG70,U,26)_" ") "RTN","DGPTR4",31,0) ;-- ir "RTN","DGPTR4",32,0) S Y=Y_$E($P(DG70,U,27)_" ") "RTN","DGPTR4",33,0) ;-- ec "RTN","DGPTR4",34,0) S Y=Y_$E($P(DG70,U,28)_" ") "RTN","DGPTR4",35,0) ;-- mst "RTN","DGPTR4",36,0) S Y=Y_$E($P(DG70,U,29)_" ") "RTN","DGPTR4",37,0) ;-- Head/Neck CA "RTN","DGPTR4",38,0) S Y=Y_$E($P(DG70,U,30)_" ") "RTN","DGPTR4",39,0) D ETHNIC "RTN","DGPTR4",40,0) D RACE "RTN","DGPTR4",41,0) D FILL "RTN","DGPTR4",42,0) I T1 F K=41:1:55,65:1:73 S Y=$E(Y,1,K-1)_" "_$E(Y,K+1,125) "RTN","DGPTR4",43,0) I T1 D CEN^DGPTR1 S:'DGERR ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1 Q "RTN","DGPTR4",44,0) I 'T1 D SAVE "RTN","DGPTR4",45,0) 702 ; "RTN","DGPTR4",46,0) Q:DG702']"" "RTN","DGPTR4",47,0) S Y="N702"_$E(Y,5,40) "RTN","DGPTR4",48,0) F K=1:1:9 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 "RTN","DGPTR4",49,0) D FILL "RTN","DGPTR4",50,0) I 'DGERR S ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1 "RTN","DGPTR4",51,0) I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y "RTN","DGPTR4",52,0) S DG702=$P(DG702,U,6,9) "RTN","DGPTR4",53,0) Q "RTN","DGPTR4",54,0) ; "RTN","DGPTR4",55,0) ENTER S Y=Y_$J($P(X,U,Z),L) "RTN","DGPTR4",56,0) Q "RTN","DGPTR4",57,0) ; "RTN","DGPTR4",58,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)) "RTN","DGPTR4",59,0) Q "RTN","DGPTR4",60,0) ; "RTN","DGPTR4",61,0) SAVE D START^DGPTR1 S:'DGERR ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1 "RTN","DGPTR4",62,0) I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y "RTN","DGPTR4",63,0) Q Q "RTN","DGPTR4",64,0) ; "RTN","DGPTR4",65,0) FILL F K=$L(Y):1:124 S Y=Y_" " "RTN","DGPTR4",66,0) Q "RTN","DGPTR4",67,0) ; "RTN","DGPTR4",68,0) CDR S Y=Y_$E($P(Z,".")_"0000",1,4)_$E($P(Z,".",2)_"00",1,2) "RTN","DGPTR4",69,0) Q "RTN","DGPTR4",70,0) ADDQUES ;-- additional PTF questions load records for trans 501/701 "RTN","DGPTR4",71,0) S DGDRUG=$S($D(^DIC(45.61,+$P(DGAUX,U,4),0)):$P(^(0),U,2),1:" ") "RTN","DGPTR4",72,0) S Y=Y_$E($P(DGAUX,U,3)_" ")_$E($P(DGAUX,U,2)_" ")_$J($P(DGDRUG,U),4) "RTN","DGPTR4",73,0) S Y=Y_$E($P(DGAUX,U,5)_" ") "RTN","DGPTR4",74,0) S DGT=0,X=$P(DGAUX,U,6) I X]"" S DGT=1,Z=1,L=2 D ENTER0 "RTN","DGPTR4",75,0) I 'DGT S Y=Y_" " "RTN","DGPTR4",76,0) S DGT=0,X=$P(DGAUX,U,7) I X]"" S DGT=1,Z=1,L=2 D ENTER0 "RTN","DGPTR4",77,0) I 'DGT S Y=Y_" " "RTN","DGPTR4",78,0) Q "RTN","DGPTR4",79,0) RTEN(X) ; This function will round X to the nearest mulitple of ten. "RTN","DGPTR4",80,0) ; 0-4 ->DOWN; 5-9->UP "RTN","DGPTR4",81,0) Q (X\10)*10+$S(X#10>4:10,1:0) "RTN","DGPTR4",82,0) ETHNIC ;-- Ethnicity (use first active value) "RTN","DGPTR4",83,0) N NODE,NUM,ETHNIC,I,X "RTN","DGPTR4",84,0) S ETHNIC="" "RTN","DGPTR4",85,0) S I=0 "RTN","DGPTR4",86,0) S NUM=1 "RTN","DGPTR4",87,0) F S I=+$O(DG06(I)) Q:'I D Q:NUM>1 "RTN","DGPTR4",88,0) .S NODE=$G(DG06(I,0)) "RTN","DGPTR4",89,0) .Q:('NODE)!('$D(^DIC(10.2,+NODE,0))) "RTN","DGPTR4",90,0) .Q:$$INACTIVE^DGUTL4(+NODE) "RTN","DGPTR4",91,0) .S X=$$PTR2CODE^DGUTL4(+NODE,2,4) "RTN","DGPTR4",92,0) .S ETHNIC=$S(X="":" ",1:X) "RTN","DGPTR4",93,0) .S X=$$PTR2CODE^DGUTL4(+$P(NODE,"^",2),3,4) "RTN","DGPTR4",94,0) .S ETHNIC=ETHNIC_$S(X="":" ",1:X) "RTN","DGPTR4",95,0) .S NUM=NUM+1 "RTN","DGPTR4",96,0) S Y=Y_$S(ETHNIC="":" ",1:ETHNIC) "RTN","DGPTR4",97,0) Q "RTN","DGPTR4",98,0) RACE ;-- Race (use first 6 active values) "RTN","DGPTR4",99,0) N NODE,NUM,RACE,I,X "RTN","DGPTR4",100,0) S RACE="" "RTN","DGPTR4",101,0) S I=0 "RTN","DGPTR4",102,0) S NUM=1 "RTN","DGPTR4",103,0) F S I=+$O(DG02(I)) Q:'I D Q:NUM>6 "RTN","DGPTR4",104,0) .S NODE=$G(DG02(I,0)) "RTN","DGPTR4",105,0) .Q:('NODE)!('$D(^DIC(10,+NODE,0))) "RTN","DGPTR4",106,0) .Q:$$INACTIVE^DGUTL4(+NODE) "RTN","DGPTR4",107,0) .S X=$$PTR2CODE^DGUTL4(+NODE,1,4) "RTN","DGPTR4",108,0) .S RACE=RACE_$S(X="":" ",1:X) "RTN","DGPTR4",109,0) .S X=$$PTR2CODE^DGUTL4(+$P(NODE,"^",2),3,4) "RTN","DGPTR4",110,0) .S RACE=RACE_$S(X="":" ",1:X) "RTN","DGPTR4",111,0) .S NUM=NUM+1 "RTN","DGPTR4",112,0) S X="" S $P(X," ",12)="" "RTN","DGPTR4",113,0) S RACE=$S(RACE="":" ",1:RACE)_X "RTN","DGPTR4",114,0) S Y=Y_$E(RACE,1,12) "RTN","DGPTR4",115,0) Q "RTN","DGRP2") 0^21^B9120510 "RTN","DGRP2",1,0) DGRP2 ;ALB/MRL - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300 "RTN","DGRP2",2,0) ;;5.3;Registration;**415**;Aug 13, 1993 "RTN","DGRP2",3,0) S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRP2",4,0) S (Z,DGRPW)=1 D WW^DGRPV W " Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=31 D WW1^DGRPV "RTN","DGRP2",5,0) S DGD=$$DISP^DG1010P0(DGRP(0),11,0,1),DGNOCITY=DGUNK,DGD1=$$POINT^DG1010P0(DGRP(0),12,5,1,0,1) "RTN","DGRP2",6,0) W "POB: ",$E($S((DGNOCITY&DGUNK):"UNANSWERED",1:DGD_$S(($L(DGD)):", ",1:"")_DGD1),1,29) "RTN","DGRP2",7,0) S DGRPX=DGRP(0) "RTN","DGRP2",8,0) W !?4,"Marital: ",$S($D(^DIC(11,+$P(DGRPX,"^",5),0)):$E($P(^(0),"^",1),1,28),1:DGRPU),?41,"Father: ",$S($P(DGRP(.24),"^",1)]"":$E($P(DGRP(.24),"^",1),1,29),1:DGRPU) "RTN","DGRP2",9,0) W !?3,"Religion: ",$S($D(^DIC(13,+$P(DGRPX,"^",8),0)):$P(^(0),"^",1),1:DGRPU),?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU) "RTN","DGRP2",10,0) S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QD"[$E(X):X_"TRAUMATIC",1:X) W !?8,"SCI: ",X "RTN","DGRP2",11,0) W ?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU) "RTN","DGRP2",12,0) W ! S Z=2 D WW^DGRPV W " Previous Care Date Location of Previous Care",!?4,"------------------ -------------------------" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X "RTN","DGRP2",13,0) E F I=1:1:4 S I1=$P(DGRPX,"^",I) X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)" I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU) "RTN","DGRP2",14,0) W ! S Z=3 D WW^DGRPV W " Ethnicity: " D "RTN","DGRP2",15,0) .I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q "RTN","DGRP2",16,0) .N NODE,NUM,ETHNIC "RTN","DGRP2",17,0) .S I=0 "RTN","DGRP2",18,0) .F NUM=0:1 S I=+$O(^DPT(DFN,.06,I)) Q:'I D "RTN","DGRP2",19,0) ..S NODE=$G(^DPT(DFN,.06,I,0)) "RTN","DGRP2",20,0) ..S X=$P($G(^DIC(10.2,+NODE,0)),"^",1) "RTN","DGRP2",21,0) ..S ETHNIC=$S(X="":"?????",1:X) "RTN","DGRP2",22,0) ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2) "RTN","DGRP2",23,0) ..S ETHNIC=ETHNIC_" ("_$S(X="":"?",1:X)_")" "RTN","DGRP2",24,0) ..I NUM S ETHNIC=", "_ETHNIC "RTN","DGRP2",25,0) ..I ($X+$L(ETHNIC))>IOM D W !?15 "RTN","DGRP2",26,0) ...F S X=$P(ETHNIC," ",1)_" " Q:($X+$L(X))>IOM W X S ETHNIC=$P(ETHNIC," ",2,999) "RTN","DGRP2",27,0) ..W ETHNIC "RTN","DGRP2",28,0) W !?9,"Race: " D "RTN","DGRP2",29,0) .I '$O(^DPT(DFN,.02,0)) W "UNANSWERED" Q "RTN","DGRP2",30,0) .N NODE,NUM,RACE "RTN","DGRP2",31,0) .S I=0 "RTN","DGRP2",32,0) .F NUM=0:1 S I=+$O(^DPT(DFN,.02,I)) Q:'I D "RTN","DGRP2",33,0) ..S NODE=$G(^DPT(DFN,.02,I,0)) "RTN","DGRP2",34,0) ..S X=$P($G(^DIC(10,+NODE,0)),"^",1) "RTN","DGRP2",35,0) ..S RACE=$S(X="":"?????",1:X) "RTN","DGRP2",36,0) ..S X=$P($G(^DIC(10.3,+$P(NODE,"^",2),0)),"^",2) "RTN","DGRP2",37,0) ..S RACE=RACE_" ("_$S(X="":"?",1:X)_")" "RTN","DGRP2",38,0) ..I NUM S RACE=", "_RACE "RTN","DGRP2",39,0) ..I ($X+$L(RACE))>IOM D W !?15 "RTN","DGRP2",40,0) ...F S X=$P(RACE," ",1)_" " Q:($X+$L(X))>IOM W X S RACE=$P(RACE," ",2,999) "RTN","DGRP2",41,0) ..W RACE "RTN","DGRP2",42,0) G ^DGRPP "RTN","DGRPE") 0^8^B34626804 "RTN","DGRPE",1,0) DGRPE ;ALB/MRL - REGISTRATIONS EDITS ; 10/27/00 12:40pm "RTN","DGRPE",2,0) ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415**;Aug 13, 1993 "RTN","DGRPE",3,0) ; "RTN","DGRPE",4,0) ;DGDR contains a string of edits; edit=screen*10+item # "RTN","DGRPE",5,0) ; "RTN","DGRPE",6,0) ;line tag screen*10+item*1000 = continuation line "RTN","DGRPE",7,0) ; "RTN","DGRPE",8,0) I DGRPS=8 D ^DGRPEIS,Q Q ; family demographic edit...not conventional!! :) "RTN","DGRPE",9,0) I DGRPS=9 D EDIT9^DGRPEIS2,Q Q ; income screening data ($$$) "RTN","DGRPE",10,0) I DGRPS=5,DGDR["501," D "RTN","DGRPE",11,0) .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q "RTN","DGRPE",12,0) .D REG^IBCNBME(DFN) "RTN","DGRPE",13,0) .Q "RTN","DGRPE",14,0) ;-- Tricare screen #15 "RTN","DGRPE",15,0) I DGRPS=15 D EDIT^DGRP15,Q Q "RTN","DGRPE",16,0) ; "RTN","DGRPE",17,0) N DGPH,DGPHFLG "RTN","DGRPE",18,0) K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0 G ^DGRPE1:DGRPS>6 F I=1:1 S J=$P(DGDR,",",I) Q:J="" F J1=J,J*1000 Q:'$T(@J1) S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",19,0) D ^DIE "RTN","DGRPE",20,0) I $G(DGPHFLG)>0 D EDITPH1^DGRPLE() "RTN","DGRPE",21,0) Q K DA,DIE,DR,DGCT,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1 "RTN","DGRPE",22,0) Q "RTN","DGRPE",23,0) S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q "RTN","DGRPE",24,0) S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q "RTN","DGRPE",25,0) Q "RTN","DGRPE",26,0) 101 ;;.01;.09;.03; "RTN","DGRPE",27,0) 102 ;;1; "RTN","DGRPE",28,0) 103 ;;.091; "RTN","DGRPE",29,0) 104 ;;S DIE("NO^")="OUTOK";.111;S:X="" Y="@1112";.112;S:X="" Y="@1112";.113;@1112;S EASZIPLK=1;.1112;K EASDO2;.114;S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131;.115;.117;.131;.132;K DIE("NO^"); "RTN","DGRPE",30,0) 105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;.1211;I X']"" W !?4,$C(7),"But I need at least one line of a Temporary address." S Y=.12105; "RTN","DGRPE",31,0) 109 ;;S DIE("NO^")="OUTOK";.111;S:X="" Y="@1112";.112;S:X="" Y="@1112";.113;@1112;S EASZIPLK=1;.1112;K EASDO2;.114;S:'$$KEY^DGREGDD1(DUZ,DA) Y=.131;.115;.117;.131;.132;.02;D 109DR^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^"); "RTN","DGRPE",32,0) 105000 ;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^"); "RTN","DGRPE",33,0) 201 ;;.02;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE; "RTN","DGRPE",34,0) 202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^"); "RTN","DGRPE",35,0) 203 ;;D 203DR^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06); "RTN","DGRPE",36,0) 301 ;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31; "RTN","DGRPE",37,0) 302 ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011; "RTN","DGRPE",38,0) 302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32; "RTN","DGRPE",39,0) 303 ;;N DGX1;I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),"^",1)']"":1,1:0) S Y=.331;.3305//NO;I X="Y" S DGX1=1 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X]"" ^(.33)=$P(X_"^^^^^^^^^^^","^",1,9)_"^"_$P(^(.33),"^",10)_"^"_$P(X,"^",11); "RTN","DGRPE",40,0) 303000 ;;I $G(DGX1) S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);S:$G(DGX1) Y=.33011;.331;S:X']"" Y="@33";.332;.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=0;@33; "RTN","DGRPE",41,0) 304 ;;.3311;S:X']"" Y="@34";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@34; "RTN","DGRPE",42,0) 305 ;;N DGX1;I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),"^",1)']"":1,1:0) S Y=.341;.3405//NO;I X="Y" S DGX1=1 S X=$S($D(^DPT(DA,.21)):^(.21),1:"") S:X]"" ^(.34)=$P(X_"^^^^^^^^^^^","^",1,9)_"^"_$P(^(.34),"^",10)_"^"_$P(X,"^",11); "RTN","DGRPE",43,0) 305000 ;;I $G(DGX1)&($D(^DPT(DFN,.22))) S $P(^(.22),U,2)=$P(^(.22),U,7);S:$G(DGX1) Y="@35";.341;S:X']"" Y="@35";.342;.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=0;@35; "RTN","DGRPE",44,0) 401 ;;.07;.31115;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@41";.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41; "RTN","DGRPE",45,0) 402 ;;.2514;.2515;I $S(X']"":1,X=3:1,X=9:1,1:0) S Y="@42";.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42; "RTN","DGRPE",46,0) 501 ;; "RTN","DGRPE",47,0) 502 ;;.381;.382///NOW; "RTN","DGRPE",48,0) 503 ;;.383; "RTN","DGRPE",49,0) 601 ;;.325;S:X']"" Y="@61";.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@61";.3291;S:X']"" Y="@61";.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@61";.3296;S:X']"" Y="@61";.3299;.3297;.3298;.3295;@61; "RTN","DGRPE",50,0) 602 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62; "RTN","DGRPE",51,0) 603 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63; "RTN","DGRPE",52,0) 604 ;;.32101//NO;S:X'="Y" Y="@64";.32104;.32105;@64; "RTN","DGRPE",53,0) 605 ;;.32102//NO;S:X'="Y" Y="@65";.32107;.32109;.3211;.3213;@65; "RTN","DGRPE",54,0) 606 ;;.32103//NO;S:X'="Y" Y="@66";.3212;.32111;@66; "RTN","DGRPE",55,0) 607 ;;.3221//NO;S:X'="Y" Y="@67";.3222;Q;.3223;@67; "RTN","DGRPE",56,0) 608 ;;.3224//NO;S:X'="Y" Y="@68";.3225;Q;.3226;@68; "RTN","DGRPE",57,0) 609 ;;.3227//NO;S:X'="Y" Y="@69";.3228;Q;.3229;@69; "RTN","DGRPE",58,0) 610 ;;.32201//NO;S:X'="Y" Y="@610";.322011;Q;.322012;@610; "RTN","DGRPE",59,0) 611 ;;.322016//NO;S:X'="Y" Y="@611";.322017;Q;.322018;@611; "RTN","DGRPE",60,0) 612 ;;.322013//NO;S:X'="Y" Y="@612";.322014;Q;.322015;@612; "RTN","DGRPE",61,0) 613 ;;.362; "RTN","DGRPE",62,0) 614 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614; "RTN","DGRPE",63,0) 615 ;;.322019//NO;S:X'="Y" Y="@615";.32202;Q;.322021;@615; "RTN","DGRPE",64,0) 616 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162; "RTN","DGRPE",65,0) 617 ;;D REG^DGNTQ(DFN); "RTN","DGRPE",66,0) AD N DGZ4,DGPC "RTN","DGRPE",67,0) S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10) "RTN","DGRPE",68,0) I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4 "RTN","DGRPE",69,0) K DGADD,DGPHONE Q "RTN","DGRPE",70,0) 109DR ;Drop through (use same logic as 203DR) "RTN","DGRPE",71,0) 203DR S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;" "RTN","DGRPE",72,0) S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;" "RTN","DGRPE",73,0) Q "RTN","DGRPH") 0^22^B27221934 "RTN","DGRPH",1,0) DGRPH ;ALB/MRL - REGISTRATION HELP ROUTINE ;06 JUN 88@2300 "RTN","DGRPH",2,0) ;;5.3;Registration;**114,343,397,415**;Aug 13, 1993 "RTN","DGRPH",3,0) S DGRPH="" D H^DGRPU K DGRPH W !,"Enter '^' to stop the display ",$S(DGRPV:"",1:"and edit "),"of data, '^N' to jump to screen #N (see",!,"listing below), to continue on to the next available screen" I DGRPV W "." G M "RTN","DGRPH",4,0) W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters. Those groups enclosed in brackets ""[]"" are editable while those",!,"enclosed in arrows ""<>"" are not." "RTN","DGRPH",5,0) W " Enter 'ALL' to edit all editable data",!,"elements on the screen." "RTN","DGRPH",6,0) M I DGRPS=9,DGRPSEL="V" W !!,"You may precede your selection with 'V' to denote veteran." "RTN","DGRPH",7,0) I DGRPS=9,DGRPSEL]"V" W !!,"To edit a specific column, enter 'V'",$S($D(DGREL("S")):", 'S'",1:""),$S($D(DGREL("D")):", 'D'",1:"")," in front of the selected items." "RTN","DGRPH",8,0) S Z="DATA GROUPS ON SCREEN "_DGRPS,DGRPCM=1 W ! D WW^DGRPV S DGRPCM=0 D @DGRPS D:$S(DGRPS<11:1,DGRPS=14:1,1:0) W D S W ! F I=$Y:1:20 W ! "RTN","DGRPH",9,0) ;S Z="Press RETURN key",DGRPCM=1 D WW^DGRPV S DGRPCM=0 W " to EXIT Screen ",DGRPS," HELP " R X:DTIME S X="" Q "RTN","DGRPH",10,0) S DGRPW=0 W "Press " S Z="",DGRPCM=1 D WW^DGRPV W " KEY " S Z="TO EXIT" D WW^DGRPV W " SCREEN ",DGRPS," " S Z="HELP" D WW^DGRPV W " " R X:DTIME S (DGRPCM,DGRPW)=0 Q "RTN","DGRPH",11,0) 1 S X="Name, SSN, DOB^Alias Name & SSN (if applicable)^Remarks concerning this patient^Home Address, Phone & Work Phone^Temporary Address, Dates, Phone" Q "RTN","DGRPH",12,0) 2 S X="Sex, POB, Parents, etc.^Dates/Locations of Previous Care^Race and Ethnicity" Q "RTN","DGRPH",13,0) 3 S X="Primary Next-of-Kin^Secondary Next-of-Kin^Primary Emergency Contact^Secondary Emergency Contact^Designee to receive personal effects" Q "RTN","DGRPH",14,0) 4 S X="Applicant Employer, Address^Spouses Employer, Address" Q "RTN","DGRPH",15,0) 5 S X="Unexpired Insurance Policies^Eligibile for Medicaid" Q "RTN","DGRPH",16,0) 6 S X="Service History^Prisoner of War^Combat^Vietnam Service^Agent Orange Exposure^IONizing Radiation Exposure^" "RTN","DGRPH",17,0) S X=X_"Lebanon Service^Grenada Service^Panama Service^Persian Gulf Service^Somalia Service^Environmental Contaminants Exposure^Military Retirement/Disability^Dental History^Yugoslavia Service^Purple Heart Recipient^" "RTN","DGRPH",18,0) S X=X_"Nose/Throat Radium Treatment" "RTN","DGRPH",19,0) Q "RTN","DGRPH",20,0) 7 S X="Patient Type, SC Data, Claim Info^VA Monetary Benefits^POS, Eligibility Code(s)^SC Conditions relayed by applicant" Q "RTN","DGRPH",21,0) 8 S X="Spouse's Demographic Info^Dependents' Demographic Info" Q "RTN","DGRPH",22,0) 9 S X="Social Security^U.S. Civil Service^U.S. Railroad Retirement^Military Retirement^Unemployment^Other Retirement^Total Employment Income^Interest,Dividend,Annuity^Workers Comp or Black Lung^Other Income" Q "RTN","DGRPH",23,0) 10 S X="Ineligible Patient Information^Missing Patient Information" Q "RTN","DGRPH",24,0) 11 S X="Eligibility Verification^Monetary Benefits Verification^Service Record Verification^Rated Disabilities (VA)" Q "RTN","DGRPH",25,0) 12 W !,"Four most recent admission episodes on file for this applicant are displayed",!,"in inverse order." Q "RTN","DGRPH",26,0) 13 W !,"Four most recent applications for care (registrations) are displayed in",!,"inverse order." Q "RTN","DGRPH",27,0) 14 S X="Clinics in which actively enrolled^Pending (future) appointments" Q "RTN","DGRPH",28,0) 15 W !,"Sponsor information is displayed for patients." Q "RTN","DGRPH",29,0) S W ! S Z="AVAILABLE SCREENS",DGRPCM=1 D WW^DGRPV S DGRPCM=0 "RTN","DGRPH",30,0) S X="Demographic^Patient^Contact^Employment^Insurance^Service Record^Eligibility^Family Demographic^Income Screening^Missing/Ineligible^Eligibility Verification^Admission Info^Application Info^Appointment Info^Sponsor Demograhics" "RTN","DGRPH",31,0) S C=0 F I=1:1 S J=$P(X,"^",I) Q:J="" I '$E(DGRPVV,I) S C=C+1,Z="^"_I,DGRPW=(C#2) D WW^DGRPV S Z=$S(I?1N:" ",1:" ")_J_" Data",Z1=$S((C#2)&(I?1N):36,(C#2):35,1:1) D WW1^DGRPV:(C#2) I '(C#2) W Z "RTN","DGRPH",32,0) Q "RTN","DGRPH",33,0) W F I=1:1 S J=$P(X,"^",I) Q:J="" S Z=I,DGRPW=(I#2) D WW^DGRPV S Z=$S(I<10:" ",1:" ")_J,Z1=$S((I#2)&(I>10):36,(I#2):37,1:1) D WW1^DGRPV "RTN","DGRPH",34,0) W:'((I-1)#2) ! Q "RTN","DGRPU1") 0^10^B6015150 "RTN","DGRPU1",1,0) DGRPU1 ;ALB/REW CUSTOM LOAD/EDIT SCREEN UTILITIES ;9-FEB-92 "RTN","DGRPU1",2,0) ;;5.3;Registration;**139,169,415**;Aug 13, 1993 "RTN","DGRPU1",3,0) ; "RTN","DGRPU1",4,0) QUES(DFN,DGQCODE) ; EDIT SPECIFIC PORTIONS OF REGISTRATION DATA "RTN","DGRPU1",5,0) ; "RTN","DGRPU1",6,0) ; INPUT: "RTN","DGRPU1",7,0) ; DFN "RTN","DGRPU1",8,0) ; DGQCODE = Code for question(s) to be asked "RTN","DGRPU1",9,0) ; OUTPUT: "RTN","DGRPU1",10,0) ; DGERR = ERROR VARIABLE "RTN","DGRPU1",11,0) ; DGCHANGE= 1 IF DATA MODIFIED 0 O/W "RTN","DGRPU1",12,0) ; USED: "RTN","DGRPU1",13,0) ; DGPTND = Prior value(s) of Patient File node(s) [array] "RTN","DGRPU1",14,0) ; DGQNODES= Node(s) used above "RTN","DGRPU1",15,0) ; DGNODE = Single node "RTN","DGRPU1",16,0) ; DGDR = edit=screen*10+item # "RTN","DGRPU1",17,0) ; DGRPS = Screen # "RTN","DGRPU1",18,0) ; DGCODE = CODE used by ^DGRPE "RTN","DGRPU1",19,0) ; DGQ = String of ^DGCODE^DGCODE etc. "RTN","DGRPU1",20,0) ; DGPC = Piece Number "RTN","DGRPU1",21,0) ; DGX = Line Tag offset "RTN","DGRPU1",22,0) ; "RTN","DGRPU1",23,0) N D,D0,DI,DIC,DGCODE,DGDR,DGNODE,DGQNODES,DGPC,DGPTND,DGRPS,DGQ,DGX "RTN","DGRPU1",24,0) N DQ,N,X,Y,%Y,DGPTNDM "RTN","DGRPU1",25,0) S (DGERR,DGRPS,DGCHANGE)=0 "RTN","DGRPU1",26,0) I '($G(DFN)&$D(DGQCODE)) G QTE "RTN","DGRPU1",27,0) F DGX=1:1 S DGQ=$T(QDES+DGX) Q:DGQ[(U_DGQCODE_U)!(DGQ']"") "RTN","DGRPU1",28,0) F DGPC=2:1 S DGCODE=$P(DGQ,U,DGPC) Q:(DGCODE']"")!(DGCODE=DGQCODE) "RTN","DGRPU1",29,0) G:DGCODE']"" QTE "RTN","DGRPU1",30,0) S DGDR=$P($T(QNUM+DGX),U,DGPC) "RTN","DGRPU1",31,0) S DGRPS=DGDR\100 "RTN","DGRPU1",32,0) S DGQNODES=$P($T(QNODE+DGX),U,DGPC) "RTN","DGRPU1",33,0) F N=1:1 S DGNODE=$P(DGQNODES,"~",N) Q:DGNODE']"" S DGPTND(DGNODE)=$G(^DPT(DFN,DGNODE)) "RTN","DGRPU1",34,0) S DGQNODES=$P($T(MNODE+DGX),U,DGPC) "RTN","DGRPU1",35,0) F N=1:1 S DGNODE=$P(DGQNODES,"~",N) Q:DGNODE']"" M DGPTNDM(DGNODE)=^DPT(DFN,DGNODE) S DGPTNDM(DGNODE)="" "RTN","DGRPU1",36,0) D ^DGRPE "RTN","DGRPU1",37,0) F DGNODE=0:0 S DGNODE=$O(DGPTND(DGNODE)) Q:DGNODE']"" S:$G(^DPT(DFN,DGNODE))'=(DGPTND(DGNODE)) DGCHANGE=1 "RTN","DGRPU1",38,0) S DGNODE="" F S DGNODE=$O(DGPTNDM(DGNODE)) Q:DGNODE']"" D Q:DGCHANGE "RTN","DGRPU1",39,0) .S X=0 F S X=$O(DGPTNDM(DGNODE,X)) Q:'X D Q:DGCHANGE "RTN","DGRPU1",40,0) ..S Y="" F S Y=$O(DGPTNDM(DGNODE,X,Y)) Q:Y']"" D Q:DGCHANGE "RTN","DGRPU1",41,0) ...I $G(^DPT(DFN,DGNODE,X,Y))'=DGPTNDM(DGNODE,X,Y) S DGCHANGE=1 "RTN","DGRPU1",42,0) .Q:DGCHANGE "RTN","DGRPU1",43,0) .S X=0 F S X=$O(^DPT(DGNODE,X)) Q:'X D Q:DGCHANGE "RTN","DGRPU1",44,0) ..S Y="" F S Y=$O(^DPT(DGNODE,X,Y)) Q:Y']"" D Q:DGCHANGE "RTN","DGRPU1",45,0) ...I $G(^DPT(DFN,DGNODE,X,Y))'=DGPTNDM(DGNODE,X,Y) S DGCHANGE=1 "RTN","DGRPU1",46,0) QTE I 'DGRPS S DGERR=1 "RTN","DGRPU1",47,0) QTQ Q "RTN","DGRPU1",48,0) QDES ;MNEMONIC - DGQCODE should match with one of these "RTN","DGRPU1",49,0) ;;^ADD1^ADD2^ADD^ADD3^ "RTN","DGRPU1",50,0) QNUM ;REFERENCE NUMBERS USED TO SET DGDR FOR USE BY ^DGRPE "RTN","DGRPU1",51,0) ;;^104^105^109,105^109,105^ "RTN","DGRPU1",52,0) ;; "RTN","DGRPU1",53,0) QNODE ;;NODES OF THE PATIENT FILE "RTN","DGRPU1",54,0) ;;^.11~.13^.121^.11~.121~.13^.11~.121~.13^ "RTN","DGRPU1",55,0) ;; "RTN","DGRPU1",56,0) MNODE ;;MULTIPLES OF THE PATIENT FILE "RTN","DGRPU1",57,0) ;;^^^.02~.06^.02~.06^ "RTN","DGRPV") 0^9^B16180219 "RTN","DGRPV",1,0) DGRPV ;ALB/MRL,RTK - REGISTRATION DEFINE VARIABLES ON ENTRY ; 11/26/02 2:40pm "RTN","DGRPV",2,0) ;;5.3;Registration;**109,114,247,190,327,365,343,397,415**;Aug 13, 1993 "RTN","DGRPV",3,0) ; "RTN","DGRPV",4,0) ; "RTN","DGRPV",5,0) ;set up variables for registration screen processing "RTN","DGRPV",6,0) ; "RTN","DGRPV",7,0) ;DGRPVV :string of 15 ones and zeros each character corresponding to "RTN","DGRPV",8,0) ; a particular screen (0 means allow edit, 1 means don't) "RTN","DGRPV",9,0) ; "RTN","DGRPV",10,0) ;DGRPVV(n):where n=screen number. String of x ones and zeros where "RTN","DGRPV",11,0) ; x is the number of elements on screen n (0=edit, 1=don't) "RTN","DGRPV",12,0) ; "RTN","DGRPV",13,0) ;DGVI :Turn on high intensity "RTN","DGRPV",14,0) ;DGVO :Turn off high intensity "RTN","DGRPV",15,0) ; "RTN","DGRPV",16,0) EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS "RTN","DGRPV",17,0) S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity "RTN","DGRPV",18,0) I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X) "RTN","DGRPV",19,0) M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM") "RTN","DGRPV",20,0) S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1) "RTN","DGRPV",21,0) SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",22,0) S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0 "RTN","DGRPV",23,0) I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10")) "RTN","DGRPV",24,0) ; "RTN","DGRPV",25,0) S DGPH=$P($G(^DPT(DFN,.53)),U) ;Purple Heart Indicator "RTN","DGRPV",26,0) I $G(DGPRFLG)=1 D "RTN","DGRPV",27,0) . S DGRPVV="000001111111111" "RTN","DGRPV",28,0) E D "RTN","DGRPV",29,0) . S DGRPVV="000000000000000" "RTN","DGRPV",30,0) S X="5^3^5^2^3^17^4^2^10^2^4^5^5^2^1" "RTN","DGRPV",31,0) F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J)) "RTN","DGRPV",32,0) I $G(DGPH)]"" S $E(DGRPVV(6),16)=1 "RTN","DGRPV",33,0) I $$GETSTAT^DGNTAPI1(DFN)>2,'$D(^XUSEC("DGNT VERIFY",DUZ)) D "RTN","DGRPV",34,0) . S $E(DGRPVV(6),17)=1 "RTN","DGRPV",35,0) ; "RTN","DGRPV",36,0) F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",37,0) ; "RTN","DGRPV",38,0) ;-- if patient type is TRICARE then turn off screens 2,4 "RTN","DGRPV",39,0) I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99) "RTN","DGRPV",40,0) ; "RTN","DGRPV",41,0) F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",42,0) I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99) "RTN","DGRPV",43,0) K DIRUT,DUOUT,DTOUT "RTN","DGRPV",44,0) ; "RTN","DGRPV",45,0) ;Fields are numbered screen_item and put in that piece position. "RTN","DGRPV",46,0) ;Because FM does not allow more than 100 pieces on a node, it was "RTN","DGRPV",47,0) ;necessary to start a new node E10 for fields on screens 10 or higher. "RTN","DGRPV",48,0) ;In these instances, the piece position will be screen_item-100 so, "RTN","DGRPV",49,0) ;for example, screen 11, item 2 would be field 112, but piece 12. "RTN","DGRPV",50,0) ;Items on screens <10 will be found on node E. "RTN","DGRPV",51,0) ; "RTN","DGRPV",52,0) F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99) "RTN","DGRPV",53,0) ; "RTN","DGRPV",54,0) I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip "RTN","DGRPV",55,0) F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"") "RTN","DGRPV",56,0) S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob "RTN","DGRPV",57,0) I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data "RTN","DGRPV",58,0) I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=11111111111111111 ;if service data verified, can't edit service screen "RTN","DGRPV",59,0) ; "RTN","DGRPV",60,0) ELVER ;set up variables for eligibility verification "RTN","DGRPV",61,0) ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10, "RTN","DGRPV",62,0) ; and 11 if they're turned on). "RTN","DGRPV",63,0) ; "RTN","DGRPV",64,0) I $P($G(^DPT(DFN,.361)),U,3)="H" S DGRPVV(10)=10,DGRPVV(11)=1001 "RTN","DGRPV",65,0) S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15) "RTN","DGRPV",66,0) I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I "RTN","DGRPV",67,0) Q K DGRPSC,DGRPSCE "RTN","DGRPV",68,0) Q "RTN","DGRPV",69,0) ; "RTN","DGRPV",70,0) WW ;Write number on screens for display and/or edit (Z=number) "RTN","DGRPV",71,0) W:DGRPW ! S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]") "RTN","DGRPV",72,0) I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO "RTN","DGRPV",73,0) I 'DGRPCM&($E(Z)'="[") W Z "RTN","DGRPV",74,0) Q "RTN","DGRPV",75,0) ; "RTN","DGRPV",76,0) WW1 ;spacing for screen display (Z=item to print) "RTN","DGRPV",77,0) F Z2=1:1:(Z1-$L(Z)) S Z=Z_" " "RTN","DGRPV",78,0) W Z K Z2 "RTN","DGRPV",79,0) Q "RTN","DGUTL4") 0^28^B10261211 "RTN","DGUTL4",1,0) DGUTL4 ;BPFO/JRP - RACE & ETHNIC UTILITIES;9/5/2002 "RTN","DGUTL4",2,0) ;;5.3;Registration;**415**;Aug 13, 1993 "RTN","DGUTL4",3,0) ; "RTN","DGUTL4",4,0) PTR2TEXT(VALUE,TYPE) ;Convert pointer to text (.01 field) "RTN","DGUTL4",5,0) ;Input: VALUE - Pointer to RACE file (#10), ETHNICITY file (#10.2), "RTN","DGUTL4",6,0) ; or RACE AND ETHNICITY COLLECTION METHOD file (#10.3) "RTN","DGUTL4",7,0) ; TYPE - Flag indicating which file VALUE is for "RTN","DGUTL4",8,0) ; 1 = Race (default) "RTN","DGUTL4",9,0) ; 2 = Ethnicity "RTN","DGUTL4",10,0) ; 3 = Collection Method "RTN","DGUTL4",11,0) ;Output: Text (.01 field) "RTN","DGUTL4",12,0) ;Notes : NULL ("") returned on bad input or if there is no code "RTN","DGUTL4",13,0) ; "RTN","DGUTL4",14,0) ;Check input "RTN","DGUTL4",15,0) S VALUE=+$G(VALUE) "RTN","DGUTL4",16,0) I 'VALUE Q "" "RTN","DGUTL4",17,0) S TYPE=$G(TYPE) "RTN","DGUTL4",18,0) S:(TYPE'?1N) TYPE=1 "RTN","DGUTL4",19,0) S:((TYPE<1)!(TYPE>3)) TYPE=1 "RTN","DGUTL4",20,0) ;Declare variables "RTN","DGUTL4",21,0) N FILE,NODE "RTN","DGUTL4",22,0) ;Grab zero node "RTN","DGUTL4",23,0) S FILE=$S(TYPE=3:$NA(^DIC(10.3)),TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10))) "RTN","DGUTL4",24,0) S NODE=$G(@FILE@(VALUE,0)) "RTN","DGUTL4",25,0) ;Return text "RTN","DGUTL4",26,0) Q $P(NODE,"^",1) "RTN","DGUTL4",27,0) ; "RTN","DGUTL4",28,0) INACTIVE(VALUE,TYPE) ;Entry marked as inactive ? "RTN","DGUTL4",29,0) ;Input: VALUE - Pointer to RACE file (#10) or ETHNICITY file (#10.2) "RTN","DGUTL4",30,0) ; TYPE - Flag indicating which file VALUE is for "RTN","DGUTL4",31,0) ; 1 = Race (default) "RTN","DGUTL4",32,0) ; 2 = Ethnicity "RTN","DGUTL4",33,0) ;Output: 0 - Entry not inactive "RTN","DGUTL4",34,0) ; 1^Date - Entry inactive (Date in FileMan format) "RTN","DGUTL4",35,0) ;Notes : 0 (zero) returned on bad input "RTN","DGUTL4",36,0) ; : Collection methods can not currently be inactivated "RTN","DGUTL4",37,0) ; "RTN","DGUTL4",38,0) ;Check input "RTN","DGUTL4",39,0) S VALUE=+$G(VALUE) "RTN","DGUTL4",40,0) I 'VALUE Q "" "RTN","DGUTL4",41,0) S TYPE=$G(TYPE) "RTN","DGUTL4",42,0) S:(TYPE'?1N) TYPE=1 "RTN","DGUTL4",43,0) S:((TYPE<1)!(TYPE>2)) TYPE=1 "RTN","DGUTL4",44,0) ;Declare variables "RTN","DGUTL4",45,0) N FILE,NODE,DATE "RTN","DGUTL4",46,0) ;Grab inactivation node "RTN","DGUTL4",47,0) S FILE=$S(TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10))) "RTN","DGUTL4",48,0) S NODE=$G(@FILE@(VALUE,.02)) "RTN","DGUTL4",49,0) ;Grab inactivation date "RTN","DGUTL4",50,0) S DATE=$P(NODE,"^",2) "RTN","DGUTL4",51,0) ;Not inactive "RTN","DGUTL4",52,0) I (('NODE)&('DATE)) Q 0 "RTN","DGUTL4",53,0) ;Inactive - include inactivation date "RTN","DGUTL4",54,0) Q "1^"_DATE "RTN","DGUTL4",55,0) ; "RTN","DGUTL4",56,0) PTR2CODE(VALUE,TYPE,CODE) ;Convert pointer to specified code "RTN","DGUTL4",57,0) ;Input: VALUE - Pointer to RACE file (#10), ETHNICITY file (#10.2), "RTN","DGUTL4",58,0) ; or RACE AND ETHNICITY COLLECTION METHOD file (#10.3) "RTN","DGUTL4",59,0) ; TYPE - Flag indicating which file VALUE is for "RTN","DGUTL4",60,0) ; 1 = Race (default) "RTN","DGUTL4",61,0) ; 2 = Ethnicity "RTN","DGUTL4",62,0) ; 3 = Collection Method "RTN","DGUTL4",63,0) ; CODE - Flag indicating which code to return "RTN","DGUTL4",64,0) ; 1 = Abbreviation (default) "RTN","DGUTL4",65,0) ; 2 = HL7 "RTN","DGUTL4",66,0) ; 3 = CDC (not applicable for Collection Method) "RTN","DGUTL4",67,0) ; 4 = PTF "RTN","DGUTL4",68,0) ;Output: Requested code "RTN","DGUTL4",69,0) ;Notes : NULL ("") returned on bad input or if there is no code "RTN","DGUTL4",70,0) ; "RTN","DGUTL4",71,0) ;Check input "RTN","DGUTL4",72,0) S VALUE=+$G(VALUE) "RTN","DGUTL4",73,0) I 'VALUE Q "" "RTN","DGUTL4",74,0) S TYPE=$G(TYPE) "RTN","DGUTL4",75,0) S:(TYPE'?1N) TYPE=1 "RTN","DGUTL4",76,0) S:((TYPE<1)!(TYPE>3)) TYPE=1 "RTN","DGUTL4",77,0) S CODE=$G(CODE) "RTN","DGUTL4",78,0) S:(CODE'?1N) CODE=1 "RTN","DGUTL4",79,0) S:((CODE<1)!(CODE>4)) CODE=1 "RTN","DGUTL4",80,0) ;No CDC code for Collection Method "RTN","DGUTL4",81,0) I ((TYPE=3)&(CODE=3)) Q "" "RTN","DGUTL4",82,0) ;Declare variables "RTN","DGUTL4",83,0) N FILE,NODEREF,NODE,PIECE "RTN","DGUTL4",84,0) ;Grab node storing code "RTN","DGUTL4",85,0) S FILE=$S(TYPE=3:$NA(^DIC(10.3)),TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10))) "RTN","DGUTL4",86,0) S NODEREF=0 "RTN","DGUTL4",87,0) S NODE=$G(@FILE@(VALUE,NODEREF)) "RTN","DGUTL4",88,0) ;Determine which piece requested code is in "RTN","DGUTL4",89,0) S PIECE=CODE+1 "RTN","DGUTL4",90,0) ;Return requested code "RTN","DGUTL4",91,0) Q $P(NODE,"^",PIECE) "RTN","DGUTL4",92,0) ; "RTN","DGUTL4",93,0) CODE2PTR(VALUE,TYPE,CODE) ;Convert specified code to pointer "RTN","DGUTL4",94,0) ;Input: VALUE - Code to convert "RTN","DGUTL4",95,0) ; TYPE - Flag indicating which file VALUE is from "RTN","DGUTL4",96,0) ; 1 = Race (file #10) (default) "RTN","DGUTL4",97,0) ; 2 = Ethnicity (file #10.2) "RTN","DGUTL4",98,0) ; 3 = Collection Method (file #10.3) "RTN","DGUTL4",99,0) ; CODE - Flag indicating which code VALUE is for "RTN","DGUTL4",100,0) ; 1 = Abbreviation (default) "RTN","DGUTL4",101,0) ; 2 = HL7 "RTN","DGUTL4",102,0) ; 3 = CDC (not applicable for Collection Method) "RTN","DGUTL4",103,0) ; 4 = PTF "RTN","DGUTL4",104,0) ;Output: Pointer to file "RTN","DGUTL4",105,0) ;Notes : 0 (zero) returned on bad input or if an entry can't be found "RTN","DGUTL4",106,0) ; "RTN","DGUTL4",107,0) ;Check input "RTN","DGUTL4",108,0) S VALUE=$G(VALUE) "RTN","DGUTL4",109,0) I VALUE="" Q 0 "RTN","DGUTL4",110,0) S TYPE=$G(TYPE) "RTN","DGUTL4",111,0) S:(TYPE'?1N) TYPE=1 "RTN","DGUTL4",112,0) S:((TYPE<1)!(TYPE>3)) TYPE=1 "RTN","DGUTL4",113,0) S CODE=$G(CODE) "RTN","DGUTL4",114,0) S:(CODE'?1N) CODE=1 "RTN","DGUTL4",115,0) S:((CODE<1)!(CODE>4)) CODE=1 "RTN","DGUTL4",116,0) ;No CDC code for Collection Method "RTN","DGUTL4",117,0) I ((TYPE=3)&(CODE=3)) Q 0 "RTN","DGUTL4",118,0) ;Declare variables "RTN","DGUTL4",119,0) N PTR,FILE,NODEREF,PIECE,FOUND "RTN","DGUTL4",120,0) S FILE=$S(TYPE=3:$NA(^DIC(10.3)),TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10))) "RTN","DGUTL4",121,0) ;Abbreviation and HL7 have x-refs "RTN","DGUTL4",122,0) I ((CODE=1)!(CODE=2)) D Q PTR "RTN","DGUTL4",123,0) .;Get pointer using x-ref "RTN","DGUTL4",124,0) .S NODEREF=$S(CODE=2:"AHL7",1:"C") "RTN","DGUTL4",125,0) .S PTR=+$O(@FILE@(NODEREF,VALUE,0)) "RTN","DGUTL4",126,0) ;CDC and PTF don't have x-refs - loop through file looking for match "RTN","DGUTL4",127,0) ;Node & piece code is stored on "RTN","DGUTL4",128,0) S NODEREF=0 "RTN","DGUTL4",129,0) S PIECE=CODE+1 "RTN","DGUTL4",130,0) S FOUND=0 "RTN","DGUTL4",131,0) S PTR=0 "RTN","DGUTL4",132,0) F S PTR=+$O(@FILE@(PTR)) Q:'PTR D Q:FOUND "RTN","DGUTL4",133,0) .S NODE=$G(@FILE@(PTR,NODEREF)) "RTN","DGUTL4",134,0) .I $P(NODE,"^",PIECE)=VALUE S FOUND=1 "RTN","DGUTL4",135,0) Q PTR "RTN","VADPT") 0^5^B16792425 "RTN","VADPT",1,0) VADPT ;ALB/MRL/MJK - RETURN PATIENT VARIABLE ARRAYS [DRIVER];07 DEC 1988 "RTN","VADPT",2,0) ;;5.3;Registration;**193,343,389,415**;Aug 13, 1993 "RTN","VADPT",3,0) ;DFN = Patient IFN [if not passed entire array returned as null] "RTN","VADPT",4,0) ; "RTN","VADPT",5,0) DEM ;Demographic Variables "RTN","VADPT",6,0) S VAN=1,VAN(1)=12,VAV="VADM" D ^VADPT0 Q "RTN","VADPT",7,0) ; "RTN","VADPT",8,0) OPD ;Other Patient Data "RTN","VADPT",9,0) S VAN=2,VAN(1)=7,VAV="VAPD" D ^VADPT0 Q "RTN","VADPT",10,0) ; "RTN","VADPT",11,0) ADD ;Current Address "RTN","VADPT",12,0) S VAN=3,VAN(1)=11,VAV="VAPA" D ^VADPT0 Q "RTN","VADPT",13,0) ; "RTN","VADPT",14,0) OAD ;Other Patient Variables "RTN","VADPT",15,0) S VAN=4,VAN(1)=11,VAV="VAOA" D ^VADPT0 Q "RTN","VADPT",16,0) ; "RTN","VADPT",17,0) INP ;Inpatient Data [pre-version 5] "RTN","VADPT",18,0) N VAINDTT S VAN=5,VAN(1)=11,VAV="VAIN",VAINDTT=$G(VAINDT) N VAINDT S:VAINDTT VAINDT=$$DATIM(VAINDTT) D ^VADPT0 Q "RTN","VADPT",19,0) ; "RTN","VADPT",20,0) IN5 ;Inpatient Data [v5.0 and above] "RTN","VADPT",21,0) N VAINDTT S VAN=6,VAN(1)=18,VAV=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")),VAINDTT=$G(VAIP("D")) S:$L(VAINDTT) VAIP("D")=VAINDTT S:VAINDTT VAIP("D")=$$DATIM(VAINDTT) D ^VADPT0 S:$L(VAINDTT) VAIP("D")=VAINDTT Q "RTN","VADPT",22,0) ; "RTN","VADPT",23,0) ELIG ;Eligibility Information "RTN","VADPT",24,0) S VAN=7,VAN(1)=9,VAV="VAEL" D ^VADPT0 Q "RTN","VADPT",25,0) ; "RTN","VADPT",26,0) MB ;Monetary Benefits "RTN","VADPT",27,0) S VAN=8,VAN(1)=9,VAV="VAMB" D ^VADPT0 Q "RTN","VADPT",28,0) ; "RTN","VADPT",29,0) SVC ;Service Information "RTN","VADPT",30,0) S VAN=9,VAN(1)=9,VAV="VASV" D ^VADPT0 Q "RTN","VADPT",31,0) ; "RTN","VADPT",32,0) REG ;Registration data "RTN","VADPT",33,0) S VAN=10,VAV="VARP" D ^VADPT0 Q "RTN","VADPT",34,0) ; "RTN","VADPT",35,0) SDE ;Enrollment Information "RTN","VADPT",36,0) S VAN=11,VAV="VAEN" D ^VADPT0 Q "RTN","VADPT",37,0) ; "RTN","VADPT",38,0) SDA ;Appointment Information "RTN","VADPT",39,0) S VAN=12,VAV="VASD" D ^VADPT0 Q "RTN","VADPT",40,0) ; "RTN","VADPT",41,0) PID ;Patient Id "RTN","VADPT",42,0) S VAN=13,VAV="VA" D ^VADPT0 Q "RTN","VADPT",43,0) ; "RTN","VADPT",44,0) TESTPAT(DFN) ;Test patient ? Returns 0 (No) or 1 (Yes) "RTN","VADPT",45,0) S DFN=+$G(DFN) I 'DFN Q 0 "RTN","VADPT",46,0) I $D(^DPT("ATEST",DFN)) Q 1 "RTN","VADPT",47,0) N NODE S NODE=$G(^DPT(DFN,0)) "RTN","VADPT",48,0) I $P(NODE,"^",21)=1 Q 1 "RTN","VADPT",49,0) I $E($P(NODE,"^",9),1,5)="00000" Q 1 "RTN","VADPT",50,0) Q 0 "RTN","VADPT",51,0) ; "RTN","VADPT",52,0) V5 S X=$S($D(^DG(43,1,"VERSION")):+^("VERSION"),1:""),VADPT("V")=$S(X<5:0,1:1) K X Q "RTN","VADPT",53,0) OERR ; "RTN","VADPT",54,0) 1 S VATAG=1 D MULT Q "RTN","VADPT",55,0) 2 S VATAG=2 D MULT Q "RTN","VADPT",56,0) 3 S VATAG=3 D MULT Q "RTN","VADPT",57,0) 4 S VATAG=4 D MULT Q "RTN","VADPT",58,0) 5 S VATAG=5 D MULT Q "RTN","VADPT",59,0) 6 S VATAG=6 D MULT Q "RTN","VADPT",60,0) 7 S VATAG=7 D MULT Q "RTN","VADPT",61,0) 8 S VATAG=8 D MULT Q "RTN","VADPT",62,0) 9 S VATAG=9 D MULT Q "RTN","VADPT",63,0) 10 S VATAG=10 D MULT Q "RTN","VADPT",64,0) 51 S VATAG=11 D MULT Q "RTN","VADPT",65,0) 52 S VATAG=12 D MULT Q "RTN","VADPT",66,0) 53 S VATAG=13 D MULT Q "RTN","VADPT",67,0) ALL S VATAG=14 D MULT Q "RTN","VADPT",68,0) A5 S VATAG=15 D MULT Q "RTN","VADPT",69,0) SEL Q:$O(VARRAY(0))']"" S VATAG=0,VATAG(2)=$P($T(TAG),";;",2) "RTN","VADPT",70,0) F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG="" I VATAG(2)[("^"_VATAG_"^") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT(VATAG),1:"") D @VATAG "RTN","VADPT",71,0) G Q "RTN","VADPT",72,0) ; "RTN","VADPT",73,0) MULT S VATAG=$P($T(TG+VATAG),";;",2) "RTN","VADPT",74,0) F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,"^",VATAG(1)) Q:VATAG(2)="" S VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"") D @(VATAG(2)) "RTN","VADPT",75,0) Q S VAROOT="" K:$D(VAROOT)'=11 VAROOT K VATAG Q "RTN","VADPT",76,0) ; "RTN","VADPT",77,0) KVA K VA "RTN","VADPT",78,0) KVAR D KVAR^VADPT0 K:$D(VAIP("V")) @(VAIP("V")) K I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY("VADPT",$J),VA200,VATEST Q "RTN","VADPT",79,0) DATIM(DATIM) ;If time not specified see if movement on that date "RTN","VADPT",80,0) Q:DATIM'?7N DATIM "RTN","VADPT",81,0) N A,B S A=$O(^DGPM("ADFN"_DFN,DATIM)),B=+$O(^(+A,0)) "RTN","VADPT",82,0) I 'A Q DATIM "RTN","VADPT",83,0) I $P($G(^DGPM(+B,0)),"^",2)=3 Q DATIM ;Next movement is discharge "RTN","VADPT",84,0) F Q:"^4^5^7^"'[(U_$P($G(^DGPM(+B,0)),"^",2)) S A=$O(^DGPM("ADFN"_DFN,A)),B=+$O(^(+A,0)) I $E(A,1,7)'=DATIM Q "RTN","VADPT",85,0) I 'A Q DATIM "RTN","VADPT",86,0) I $E(A,1,7)'=DATIM Q DATIM "RTN","VADPT",87,0) Q A "RTN","VADPT",88,0) ; "RTN","VADPT",89,0) TG ; "RTN","VADPT",90,0) ;;DEM^INP "RTN","VADPT",91,0) ;;DEM^ELIG "RTN","VADPT",92,0) ;;ELIG^INP "RTN","VADPT",93,0) ;;DEM^ADD "RTN","VADPT",94,0) ;;ADD^INP "RTN","VADPT",95,0) ;;DEM^ELIG^ADD "RTN","VADPT",96,0) ;;ELIG^SVC "RTN","VADPT",97,0) ;;ELIG^SVC^MB "RTN","VADPT",98,0) ;;DEM^REG^SDE^SDA "RTN","VADPT",99,0) ;;SDE^SDA "RTN","VADPT",100,0) ;;DEM^IN5 "RTN","VADPT",101,0) ;;ELIG^IN5 "RTN","VADPT",102,0) ;;ADD^IN5 "RTN","VADPT",103,0) ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA "RTN","VADPT",104,0) ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA "RTN","VADPT",105,0) ; "RTN","VADPT",106,0) TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^ "RTN","VADPT0") 0^6^B10884518 "RTN","VADPT0",1,0) VADPT0 ;ALB/MRL/MJK - PATIENT VARIABLE ROUTINE DRIVER, CONT.; 12 DEC 1988 "RTN","VADPT0",2,0) ;;5.3;Registration;**343,342,415**;Aug 13, 1993 "RTN","VADPT0",3,0) ; "RTN","VADPT0",4,0) ;Initialize variables "RTN","VADPT0",5,0) N I1 "RTN","VADPT0",6,0) S U="^" D DT^DICRW:'$D(DT) "RTN","VADPT0",7,0) S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(DFN,0)):1,1:0) "RTN","VADPT0",8,0) S Y=VAN'=13 I Y,$D(VAROOT)'[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",10,0) D @VAN "RTN","VADPT0",11,0) Q K X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ Q "RTN","VADPT0",12,0) ; "RTN","VADPT0",13,0) INIT ; -- determine #'s or names then init array "RTN","VADPT0",14,0) ; "RTN","VADPT0",15,0) S VAS="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18" "RTN","VADPT0",16,0) I VAN<10,$D(VAHOW),VAHOW[1 S VAS=$P($T(SS+VAN),";;",2) "RTN","VADPT0",17,0) I $D(VAN(1)) F I=1:1:VAN(1) S @VAV@($P(VAS,"^",I))="" "RTN","VADPT0",18,0) Q "RTN","VADPT0",19,0) ; "RTN","VADPT0",20,0) 1 ; -- [DEM] demos "RTN","VADPT0",21,0) D C1,INIT I 'VAERR D 1^VADPT1,13 Q "RTN","VADPT0",22,0) ; "RTN","VADPT0",23,0) 2 ; -- [OPD] other pt vars "RTN","VADPT0",24,0) D C2,INIT,2^VADPT1:'VAERR Q "RTN","VADPT0",25,0) ; "RTN","VADPT0",26,0) 3 ; -- [ADD] current address "RTN","VADPT0",27,0) D C3,INIT,3^VADPT1:'VAERR Q "RTN","VADPT0",28,0) ; "RTN","VADPT0",29,0) 4 ; -- [OAD] other pt vars "RTN","VADPT0",30,0) D C4,INIT,4^VADPT1:'VAERR Q "RTN","VADPT0",31,0) ; "RTN","VADPT0",32,0) 5 ; -- [INP] inpt data -v5 "RTN","VADPT0",33,0) D C5,INIT,5^VADPT2:'VAERR Q "RTN","VADPT0",34,0) ; "RTN","VADPT0",35,0) 6 ; -- [IN5] inpt data v5 "RTN","VADPT0",36,0) D C6,INIT F I=13:1:17 F I1=1:1:7 S @VAV@($P(VAS,"^",I),I1)="" "RTN","VADPT0",37,0) D 6^VADPT3:'VAERR Q "RTN","VADPT0",38,0) ; "RTN","VADPT0",39,0) 7 ; -- [ELIG] elig data "RTN","VADPT0",40,0) D C7,INIT F I=1:1:6 S @VAV@($P(VAS,"^",5),I)="" "RTN","VADPT0",41,0) D 7^VADPT4:'VAERR Q "RTN","VADPT0",42,0) ; "RTN","VADPT0",43,0) 8 ; -- [MB] $ benefits "RTN","VADPT0",44,0) D C8,INIT D 8^VADPT4:'VAERR Q "RTN","VADPT0",45,0) ; "RTN","VADPT0",46,0) 9 ; -- [SVC] service data "RTN","VADPT0",47,0) D C9,INIT F I=1:1:9 S @VAV@($P(VAS,"^",I),1)="",@VAV@($P(VAS,"^",I),2)="" "RTN","VADPT0",48,0) S @VAV@($P(VAS,"^",4),3)="",@VAV@($P(VAS,"^",5),3)="" "RTN","VADPT0",49,0) F I=2,6,7,8 F I1=3,4,5 S @VAV@($P(VAS,"^",I),I1)="" "RTN","VADPT0",50,0) D 9^VADPT4:'VAERR Q "RTN","VADPT0",51,0) ; "RTN","VADPT0",52,0) 10 ; -- [REG] registration data "RTN","VADPT0",53,0) D C10,INIT D 10^VADPT5:'VAERR Q "RTN","VADPT0",54,0) ; "RTN","VADPT0",55,0) 11 ; -- [SDE] clinic enrollment data "RTN","VADPT0",56,0) D C11,INIT D 11^VADPT5:'VAERR Q "RTN","VADPT0",57,0) ; "RTN","VADPT0",58,0) 12 ; -- [SDA] appt data "RTN","VADPT0",59,0) D C12,INIT D 12^VADPT5:'VAERR Q "RTN","VADPT0",60,0) ; "RTN","VADPT0",61,0) 13 ; -- [PID] pt id's "RTN","VADPT0",62,0) S (VA("PID"),VA("BID"))="" D 13^VADPT6:'VAERR Q "RTN","VADPT0",63,0) ; "RTN","VADPT0",64,0) KVAR ; kill all vadpt data "RTN","VADPT0",65,0) K VAN "RTN","VADPT0",66,0) C1 K ^UTILITY("VADM",$J),VADM Q:$D(VAN) "RTN","VADPT0",67,0) C2 K ^UTILITY("VAPD",$J),VAPD Q:$D(VAN) "RTN","VADPT0",68,0) C3 K X S:$D(VAPA("P")) X("P")=VAPA("P") "RTN","VADPT0",69,0) K ^UTILITY("VAPA",$J),VAPA "RTN","VADPT0",70,0) S:$D(X("P")) VAPA("P")=X("P") K X Q:$D(VAN) "RTN","VADPT0",71,0) C4 K X S:$D(VAOA("A")) X("A")=VAOA("A") "RTN","VADPT0",72,0) K ^UTILITY("VAOA",$J),VAOA "RTN","VADPT0",73,0) S:$D(X("A")) VAOA("A")=X("A") K X Q:$D(VAN) "RTN","VADPT0",74,0) C5 K ^UTILITY("VAIN",$J),VAIN Q:$D(VAN) "RTN","VADPT0",75,0) C6 K X F I="D","E","L","M","V" I $D(VAIP(I)) S X(I)=VAIP(I) "RTN","VADPT0",76,0) S Y=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")) K ^UTILITY(Y,$J),@Y "RTN","VADPT0",77,0) F I="D","E","L","M","V" I $D(X(I)) S VAIP(I)=X(I) "RTN","VADPT0",78,0) K X Q:$D(VAN) "RTN","VADPT0",79,0) C7 K ^UTILITY("VAEL",$J),VAEL Q:$D(VAN) "RTN","VADPT0",80,0) C8 K ^UTILITY("VAMB",$J),VAMB Q:$D(VAN) "RTN","VADPT0",81,0) C9 K ^UTILITY("VASV",$J),VASV Q:$D(VAN) "RTN","VADPT0",82,0) C10 K ^UTILITY("VARP",$J) Q:$D(VAN) "RTN","VADPT0",83,0) C11 K ^UTILITY("VAEN",$J) Q:$D(VAN) "RTN","VADPT0",84,0) C12 K ^UTILITY("VASD",$J) Q "RTN","VADPT0",85,0) C13 Q "RTN","VADPT0",86,0) ; "RTN","VADPT0",87,0) SS ; 1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17^18 "RTN","VADPT0",88,0) ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS^ET^RC "RTN","VADPT0",89,0) ;;BC^BS^FN^MN^MM^OC^ES "RTN","VADPT0",90,0) ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE^Z4 "RTN","VADPT0",91,0) ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE^Z4 "RTN","VADPT0",92,0) ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT^AP "RTN","VADPT0",93,0) ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN^AP "RTN","VADPT0",94,0) ;;EL^PS^SC^VT^IN^TY^CN^ES^MT "RTN","VADPT0",95,0) ;;AA^HB^SS^PE^MR^SI^DI^OR^GI "RTN","VADPT0",96,0) ;;VN^AO^IR^PW^CS^S1^S2^S3^PH "RTN","VADPT1") 0^7^B25184957 "RTN","VADPT1",1,0) VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES; 08 DEC 1988 "RTN","VADPT1",2,0) ;;5.3;Registration;**415**;Aug 13, 1993 "RTN","VADPT1",3,0) 1 ;Demographic [DEM] "RTN","VADPT1",4,0) N W,Z,NODE "RTN","VADPT1",5,0) ; "RTN","VADPT1",6,0) ; -- name [1 - NM] "RTN","VADPT1",7,0) S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^") "RTN","VADPT1",8,0) ; "RTN","VADPT1",9,0) ; -- ssn [2 - SS] "RTN","VADPT1",10,0) S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"") "RTN","VADPT1",11,0) ; "RTN","VADPT1",12,0) ; -- date of birth [2 - DB] "RTN","VADPT1",13,0) S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y "RTN","VADPT1",14,0) ; "RTN","VADPT1",15,0) ; -- age [4 - AG] "RTN","VADPT1",16,0) S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) "RTN","VADPT1",17,0) ; "RTN","VADPT1",18,0) ; -- expired date [6 - EX] "RTN","VADPT1",19,0) S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y "RTN","VADPT1",20,0) ; "RTN","VADPT1",21,0) ; -- sex [5 - SX] "RTN","VADPT1",22,0) S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z "RTN","VADPT1",23,0) ; "RTN","VADPT1",24,0) ; -- remarks [7 - RE] "RTN","VADPT1",25,0) S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10) "RTN","VADPT1",26,0) ; "RTN","VADPT1",27,0) ; -- historic race [8 - RA] "RTN","VADPT1",28,0) S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",29,0) ; "RTN","VADPT1",30,0) ; -- religion [9 - RP] "RTN","VADPT1",31,0) S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",32,0) ; "RTN","VADPT1",33,0) ; -- marital status [10 - MS] "RTN","VADPT1",34,0) S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"") "RTN","VADPT1",35,0) ; "RTN","VADPT1",36,0) ; -- ethnicity [11 - ET] "RTN","VADPT1",37,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X D "RTN","VADPT1",38,0) .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",39,0) ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1) "RTN","VADPT1",40,0) ..; -- collection method "RTN","VADPT1",41,0) ..S Z=$P(NODE,"^",2) "RTN","VADPT1",42,0) ..S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",43,0) S @VAV@($P(VAS,"^",11))=Y-1 "RTN","VADPT1",44,0) ; "RTN","VADPT1",45,0) ; -- race [12 - RC] "RTN","VADPT1",46,0) S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X D "RTN","VADPT1",47,0) .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D "RTN","VADPT1",48,0) ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1) "RTN","VADPT1",49,0) ..; -- collection method "RTN","VADPT1",50,0) ..S Z=$P(NODE,"^",2) "RTN","VADPT1",51,0) ..S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1) "RTN","VADPT1",52,0) S @VAV@($P(VAS,"^",12))=Y-1 "RTN","VADPT1",53,0) Q "RTN","VADPT1",54,0) ; "RTN","VADPT1",55,0) 2 ;Other Patient Variables [OPD] "RTN","VADPT1",56,0) N W,Z "RTN","VADPT1",57,0) S VAX=^DPT(DFN,0) "RTN","VADPT1",58,0) ; "RTN","VADPT1",59,0) ; -- city of birth [1 - BC] "RTN","VADPT1",60,0) S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11) "RTN","VADPT1",61,0) ; "RTN","VADPT1",62,0) ; -- state of birth [2 - BS] "RTN","VADPT1",63,0) S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"") "RTN","VADPT1",64,0) ; "RTN","VADPT1",65,0) ; -- occupation [6 - OC] "RTN","VADPT1",66,0) S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7) "RTN","VADPT1",67,0) ; "RTN","VADPT1",68,0) ; -- names "RTN","VADPT1",69,0) S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"") "RTN","VADPT1",70,0) S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's [3 - FN] "RTN","VADPT1",71,0) S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's [4 - MN] "RTN","VADPT1",72,0) S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM] "RTN","VADPT1",73,0) ; "RTN","VADPT1",74,0) ; -- employment status [7 - ES] "RTN","VADPT1",75,0) S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN" "RTN","VADPT1",76,0) S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"") "RTN","VADPT1",77,0) Q "RTN","VADPT1",78,0) ; "RTN","VADPT1",79,0) 3 ;Address [ADD] "RTN","VADPT1",80,0) S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT) "RTN","VADPT1",81,0) I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)6:1,1:0) S VAX=.21,VAOA("A")=7 "RTN","VADPT1",95,0) E S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A")) "RTN","VADPT1",96,0) S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99) "RTN","VADPT1",97,0) S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",98,0) S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8 "RTN","VADPT1",99,0) F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I) "RTN","VADPT1",100,0) I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))="" "RTN","VADPT1",101,0) S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1) "RTN","VADPT1",102,0) S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A")) "RTN","VADPT1",103,0) S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9)) "RTN","VADPT1",104,0) Q "RTN","VAFCA04") 0^25^B13594719 "RTN","VAFCA04",1,0) VAFCA04 ;ALB/RJS-Creates the Registration Message ; 21 Nov 2002 3:13 PM "RTN","VAFCA04",2,0) ;;5.3;Registration;**91,209,149,261,298,415**;Aug 13, 1993 "RTN","VAFCA04",3,0) ; "RTN","VAFCA04",4,0) ;07/07/00 ACS - Added sequence 21 (physical treating specialty - ward "RTN","VAFCA04",5,0) ;location) and sequence 39 (facility+suffix) to the inpatient string "RTN","VAFCA04",6,0) ;of fields. Added sequence 39 to the outpatient string of fields. "RTN","VAFCA04",7,0) ; "RTN","VAFCA04",8,0) EN(DFN,VAFCDATE,USER,PIVOTPTR) ; "RTN","VAFCA04",9,0) Q:($G(DFN)="")!($G(VAFCDATE)="") "-1^Missing required parameter(s)" "RTN","VAFCA04",10,0) N ERR,VCCI,SITE,FS,VAFCDT,VAFHPIV,REP,DGREL,DGINC,DGINR,DGDEP,VAFSTR "RTN","VAFCA04",11,0) N ICN,CHKSUM,SETICN,SETLOC,HLA,HLRST,PV1 "RTN","VAFCA04",12,0) ; "RTN","VAFCA04",13,0) ;check HL7 V2.3 messaging flag "RTN","VAFCA04",14,0) N SEND S SEND=$P($$SEND^VAFHUTL(),"^",2) "RTN","VAFCA04",15,0) Q:SEND=0 "-1^Stop HL7 V2.3 messaging flag is set" "RTN","VAFCA04",16,0) ; "RTN","VAFCA04",17,0) S USER=+$G(USER) "RTN","VAFCA04",18,0) I 'USER,$D(DUZ) S USER=DUZ "RTN","VAFCA04",19,0) I 'USER,'$D(DUZ) S USER=0 "RTN","VAFCA04",20,0) S PIVOTPTR=+$G(PIVOTPTR) "RTN","VAFCA04",21,0) I 'PIVOTPTR D "RTN","VAFCA04",22,0) .S VAFHPIV=+$$PIVNW^VAFHPIVT(DFN,VAFCDATE,3,DFN_";DPT(") "RTN","VAFCA04",23,0) .Q:+VAFHPIV<0 "RTN","VAFCA04",24,0) .S PIVOTPTR=+$O(^VAT(391.71,"D",VAFHPIV,0)) "RTN","VAFCA04",25,0) ; "RTN","VAFCA04",26,0) Q:+$G(VAFHPIV)<0 "-1^Could Not Create ADT/HL7 Pivot file entry" "RTN","VAFCA04",27,0) K ERR "RTN","VAFCA04",28,0) ;log edited field(s) in the ADT/HL7 "RTN","VAFCA04",29,0) I $D(VAFCFLDS) D "RTN","VAFCA04",30,0) . S VAFCFLDS=$$PROCESS^VAFCDD01() "RTN","VAFCA04",31,0) . Q:VAFCFLDS'=-1 "RTN","VAFCA04",32,0) . D REGEDIT^VAFCDD01(PIVOTPTR,VAFCFLDS) "RTN","VAFCA04",33,0) ;Messaging flag set to SUSPEND - flag entry in ADT/HL7 Pivot file "RTN","VAFCA04",34,0) ; for transmission and quit "RTN","VAFCA04",35,0) I SEND=2 D TRANSMIT^VAFCDD01(PIVOTPTR) Q 1 "RTN","VAFCA04",36,0) K VAFCFLDS "RTN","VAFCA04",37,0) D INIT^HLFNC2("VAFC ADT-A04 SERVER",.HL) "RTN","VAFCA04",38,0) Q:$G(HL)]"" "-1^VAFC A04 SERVER NOT DEFINED PROPERLY" "RTN","VAFCA04",39,0) S FS=HL("FS"),REP=$E(HL("ECH")) "RTN","VAFCA04",40,0) ; "RTN","VAFCA04",41,0) S VAFCDT=$$HLDATE^HLFNC(VAFCDATE,"TS") "RTN","VAFCA04",42,0) S HLA("HLS",1)="EVN"_HLFS_"A04"_HLFS_VAFCDT_HLFS_HLFS_HLFS_USER_REP "RTN","VAFCA04",43,0) S DIC="^VA(200,",DIC(0)="MZO",X="`"_USER D ^DIC K DIC "RTN","VAFCA04",44,0) N DGNAME S DGNAME("FILE")=200,DGNAME("IENS")=USER,DGNAME("FIELD")=.01 "RTN","VAFCA04",45,0) I USER'=0 S HLA("HLS",1)=HLA("HLS",1)_$$HLNAME^XLFNAME(.DGNAME,"",$E($G(HLECH))) "RTN","VAFCA04",46,0) ; ^ possible to not have a user defined "RTN","VAFCA04",47,0) K Y S VAFSTR=$$COMMANUM^VAFCADT2(1,9)_",10B,"_$$COMMANUM^VAFCADT2(11,21)_",22B,"_$$COMMANUM^VAFCADT2(23,30) "RTN","VAFCA04",48,0) S HLA("HLS",2)=$$EN^VAFCPID(DFN,VAFSTR) "RTN","VAFCA04",49,0) ;CHECK IF PATIENT HAS AN ICN "RTN","VAFCA04",50,0) I $P(HLA("HLS",2),HLFS,3)=HLQ D "RTN","VAFCA04",51,0) . N X S X="MPIF001" X ^%ZOSF("TEST") Q:'$T "RTN","VAFCA04",52,0) . ; if patient does not have an ICN still pass HLQ "RTN","VAFCA04",53,0) . S ICN=$$GETICN^MPIF001(DFN) "RTN","VAFCA04",54,0) . I +ICN>0 S $P(HLA("HLS",2),HLFS,3)=ICN "RTN","VAFCA04",55,0) MERGE HLA("HLS",2)=VAFPID K VAFPID "RTN","VAFCA04",56,0) S VAFSTR=$$COMMANUM^VAFCADT2(1,12) "RTN","VAFCA04",57,0) S HLA("HLS",3)=$$EN^VAFHLPD1(DFN,VAFSTR) "RTN","VAFCA04",58,0) S VAFHPIV=$P($G(^VAT(391.71,PIVOTPTR,0)),"^",2) "RTN","VAFCA04",59,0) Q:VAFHPIV'>0 "-1^COULDN'T FIND PIVOT ENTRY" "RTN","VAFCA04",60,0) I $G(^DPT(DFN,.1))]"" S PV1=$$EN^VAFHAPV1(DFN,VAFCDATE,",2,3,7,8,10,18,21,39,44,45,50") "RTN","VAFCA04",61,0) E S PV1=$$OPV1^VAFHCPV(DFN,+VAFHPIV,VAFCDATE,DFN_";DPT(",",2,3,7,18,39,45,50",1) "RTN","VAFCA04",62,0) S HLA("HLS",4)=PV1 "RTN","VAFCA04",63,0) S HLA("HLS",5)=$$EN^VAFHLOBX(DFN) "RTN","VAFCA04",64,0) S VAFSTR=$$COMMANUM^VAFCADT2(1,21) "RTN","VAFCA04",65,0) S HLA("HLS",6)=$$EN^VAFHLZPD(DFN,VAFSTR) "RTN","VAFCA04",66,0) S VAFSTR=$$COMMANUM^VAFCADT2(1,5) "RTN","VAFCA04",67,0) S HLA("HLS",7)=$$EN^VAFHLZSP(DFN) "RTN","VAFCA04",68,0) S VAFSTR=$$COMMANUM^VAFCADT2(1,22) "RTN","VAFCA04",69,0) S HLA("HLS",8)=$$EN^VAFHLZEL(DFN,VAFSTR) "RTN","VAFCA04",70,0) S HLA("HLS",9)=$$EN^VAFHLZCT(DFN,"1,2,3,4,5,6,7,8,9") "RTN","VAFCA04",71,0) S HLA("HLS",10)=$$EN^VAFHLZEM(DFN,"1,2,3,4,5,6,7,8") "RTN","VAFCA04",72,0) S HLA("HLS",11)="ZFF"_HL("FS")_2_HL("FS")_$P($G(^VAT(391.71,+$G(PIVOTPTR),2)),U) "RTN","VAFCA04",73,0) D ALL^DGMTU21(DFN,"V",VAFCDATE,"R") "RTN","VAFCA04",74,0) S VAFSTR=$$COMMANUM^VAFCADT2(1,13) "RTN","VAFCA04",75,0) S HLA("HLS",12)=$$EN^VAFHLZIR(+$G(DGINR("V")),VAFSTR,1) "RTN","VAFCA04",76,0) S VAFSTR=$$COMMANUM^VAFCADT2(1,10) "RTN","VAFCA04",77,0) S HLA("HLS",13)=$$EN^VAFHLZEN(DFN,VAFSTR,1,HL("Q"),HL("FS")) "RTN","VAFCA04",78,0) D GENERATE^HLMA("VAFC ADT-A04 SERVER","LM",1,.HLRST,"",.HL) "RTN","VAFCA04",79,0) ;Store result in pivot file "RTN","VAFCA04",80,0) S HLRST=$S(+HLRST:HLRST,1:$P(HLRST,U,3)) "RTN","VAFCA04",81,0) I +HLRST>0 D MESSAGE^VAFCDD01(PIVOTPTR,+HLRST) "RTN","VAFCA04",82,0) D FILERM^VAFCUTL($O(^VAT(391.71,"D",+VAFHPIV,0)),HLRST) "RTN","VAFCA04",83,0) ; "RTN","VAFCA04",84,0) EX ; "RTN","VAFCA04",85,0) Q 1 "RTN","VAFCA04",86,0) ; "RTN","VAFCA04",87,0) HL7A04(PIVOTNUM,IEN) ; "RTN","VAFCA04",88,0) ;A new Registration was created capture the key demographic data. "RTN","VAFCA04",89,0) ;Create an HL7 V2.3 entry in the ADT/HL PIVOT file so that the "RTN","VAFCA04",90,0) ;demographic data can be broadcasted. "RTN","VAFCA04",91,0) ; VAFCFLDS is set in routine VAFCDD01. It contains the "RTN","VAFCA04",92,0) ; fields that were edited. "RTN","VAFCADT2") 0^26^B18812439 "RTN","VAFCADT2",1,0) VAFCADT2 ;ALB/RJS - HL7 ADT MESSAGE BUILDING ROUTINE ; 21 Nov 2002 3:13 PM "RTN","VAFCADT2",2,0) ;;5.3;Registration;**91,179,209,415**;Aug 13, 1993 "RTN","VAFCADT2",3,0) ;hl7v1.6 "RTN","VAFCADT2",4,0) ; "RTN","VAFCADT2",5,0) ;This routine builds ADT HL7 messages: A01 = Admission "RTN","VAFCADT2",6,0) ; A02 = Transfer "RTN","VAFCADT2",7,0) ; A03 = Discharge "RTN","VAFCADT2",8,0) ; A08 = Treating Specialty Update "RTN","VAFCADT2",9,0) ; A11 = Cancel Admission "RTN","VAFCADT2",10,0) ; A12 = Cancel Transfer "RTN","VAFCADT2",11,0) ; A13 = Cancel Discharge "RTN","VAFCADT2",12,0) ; "RTN","VAFCADT2",13,0) ;It is called by VAFCADT1, which is itself is called by the "RTN","VAFCADT2",14,0) ;DGPM patient movement event driver. "RTN","VAFCADT2",15,0) ; "RTN","VAFCADT2",16,0) ; "RTN","VAFCADT2",17,0) BLDMSG(DFN,EVENT,VAFHDT,EVCODE,IEN,PIVOT,PV1) ; "RTN","VAFCADT2",18,0) ;Required Variables are: DFN = IEN of Patient File "RTN","VAFCADT2",19,0) ; EVENT = HL7 Event, A01, A02, A03, etc. "RTN","VAFCADT2",20,0) ; VAFHDT = Date/Time of Admission, Transfer, etc "RTN","VAFCADT2",21,0) ; "RTN","VAFCADT2",22,0) ;Optional Variables are: Event Code = (EVCODE):A string literal which is "RTN","VAFCADT2",23,0) ; inserted in the Event Reason "RTN","VAFCADT2",24,0) ; Code Field of the EVN segment "RTN","VAFCADT2",25,0) ; of the message. This serves to "RTN","VAFCADT2",26,0) ; indicate that the message might "RTN","VAFCADT2",27,0) ; need to be processed in a special "RTN","VAFCADT2",28,0) ; way. PIMS ADT software uses the "RTN","VAFCADT2",29,0) ; Event Code to indicate whether "RTN","VAFCADT2",30,0) ; the message is the most recent "RTN","VAFCADT2",31,0) ; "Snapshot" of the data "05" or "RTN","VAFCADT2",32,0) ; a "Snapshot" of data that is "RTN","VAFCADT2",33,0) ; followed by more recent data "04" "RTN","VAFCADT2",34,0) ; "RTN","VAFCADT2",35,0) ; "RTN","VAFCADT2",36,0) ; IEN = The IEN of the Patient Movement "RTN","VAFCADT2",37,0) ; that the HL7 message is being "RTN","VAFCADT2",38,0) ; built from. This is especially "RTN","VAFCADT2",39,0) ; useful for Discharge Movements "RTN","VAFCADT2",40,0) ; where date/time (VAFHDT) is not "RTN","VAFCADT2",41,0) ; enough information to retrieve "RTN","VAFCADT2",42,0) ; the movement "RTN","VAFCADT2",43,0) ; "RTN","VAFCADT2",44,0) ; PIVOT = The PIMS Pivot number that "RTN","VAFCADT2",45,0) ; uniquely identifies the ADMISSION "RTN","VAFCADT2",46,0) ; "RTN","VAFCADT2",47,0) ; PV1 = In the case of a "Deleted "RTN","VAFCADT2",48,0) ; Admission" the record in the "RTN","VAFCADT2",49,0) ; Patient Movement File has already "RTN","VAFCADT2",50,0) ; been deleted. But, a PV1 segment "RTN","VAFCADT2",51,0) ; can be built from the DGPMP "RTN","VAFCADT2",52,0) ; variable that has been saved off "RTN","VAFCADT2",53,0) ; by the DGPM Event Driver. This "RTN","VAFCADT2",54,0) ; PV1 segment is passed a string "RTN","VAFCADT2",55,0) ; literal that is built by a call "RTN","VAFCADT2",56,0) ; to DGBUILD^VAFHAPV1 previous to "RTN","VAFCADT2",57,0) ; calling this software. "RTN","VAFCADT2",58,0) ; "RTN","VAFCADT2",59,0) K HLA N VAFDIAG,LIN,VAFSTR,DGREL,DGINC,DGINR,DGDEP,VAFZEL "RTN","VAFCADT2",60,0) ;Q:($G(EVCODE)'="05") "RTN","VAFCADT2",61,0) ; "RTN","VAFCADT2",62,0) K HL "RTN","VAFCADT2",63,0) I EVENT="A08" D INIT^HLFNC2("VAFC ADT-A08-TSP SERVER",.HL) "RTN","VAFCADT2",64,0) I EVENT'="A08" D INIT^HLFNC2("VAFC ADT-"_EVENT_" SERVER",.HL) "RTN","VAFCADT2",65,0) I $D(HL)#2 G EXIT "RTN","VAFCADT2",66,0) S VAFSTR=$$COMMANUM^VAFCADT2(2,9)_",10B,"_$$COMMANUM^VAFCADT2(11,21)_",22B,"_$$COMMANUM^VAFCADT2(23,30) "RTN","VAFCADT2",67,0) S HLA("HLS",2)=$$EN^VAFCPID(DFN,VAFSTR) "RTN","VAFCADT2",68,0) ;I $G(VAFPID(1))]"" S HLA("HLS",LIN,1)=VAFPID(1) "RTN","VAFCADT2",69,0) ;I $G(VAFPID(2))]"" S HLA("HLS",LIN,2)=VAFPID(2) "RTN","VAFCADT2",70,0) MERGE HLA("HLS",2)=VAFPID K VAFPID "RTN","VAFCADT2",71,0) S $P(HLA("HLS",2),HLFS,2)=1 ;SET ID "RTN","VAFCADT2",72,0) S VAFSTR=$$COMMANUM(1,12) "RTN","VAFCADT2",73,0) S HLA("HLS",3)=$$EN^VAFHLPD1(DFN,VAFSTR) "RTN","VAFCADT2",74,0) S VAFSTR=$$COMMANUM(1,21) "RTN","VAFCADT2",75,0) S HLA("HLS",4)=$$EN^VAFHLZPD(DFN,VAFSTR) "RTN","VAFCADT2",76,0) S $P(HLA("HLS",4),HLFS,2)=1 ;SET ID "RTN","VAFCADT2",77,0) I EVENT="A11" D G NEXT "RTN","VAFCADT2",78,0) . S HLA("HLS",5)=PV1 "RTN","VAFCADT2",79,0) . S $P(HLA("HLS",5),HLFS,51)=$G(PIVOT) ; VISIT&SET ID'S "RTN","VAFCADT2",80,0) I EVENT="A01"!(EVENT="A03")!(EVENT="A08")!(EVENT="A12")!(EVENT="A13") D G NEXT "RTN","VAFCADT2",81,0) . S VAFSTR=$$COMMANUM(2,5)_","_$$COMMANUM(7,45) "RTN","VAFCADT2",82,0) . S HLA("HLS",5)=$$IN^VAFHLPV1(DFN,VAFHDT,VAFSTR,$G(IEN),PIVOT,"",.VAFDIAG) "RTN","VAFCADT2",83,0) I EVENT="A02" D G NEXT "RTN","VAFCADT2",84,0) . S VAFSTR=$$COMMANUM(2,45) "RTN","VAFCADT2",85,0) . S HLA("HLS",5)=$$IN^VAFHLPV1(DFN,VAFHDT,VAFSTR,$G(IEN),PIVOT,"",.VAFDIAG) "RTN","VAFCADT2",86,0) G EXIT "RTN","VAFCADT2",87,0) NEXT ; "RTN","VAFCADT2",88,0) S $P(HLA("HLS",5),HLFS,2)=1 ;PV1 SET ID "RTN","VAFCADT2",89,0) S HLA("HLS",1)="EVN"_HLFS_EVENT_HLFS_$$HLDATE^HLFNC(VAFHDT,"TS")_HLFS "RTN","VAFCADT2",90,0) S HLA("HLS",1)=HLA("HLS",1)_HLFS_$G(EVCODE) ;,1 "RTN","VAFCADT2",91,0) I (EVENT="A01")!(EVENT="A08")!(EVENT="A11")!(EVENT="A12")!(EVENT="A13") DO "RTN","VAFCADT2",92,0) . S HLA("HLS",6)="DG1"_HLFS_1_HLFS_HLFS_HLFS_$$HLQ^VAFHUTL($G(VAFDIAG)) "RTN","VAFCADT2",93,0) S VAFSTR=$$COMMANUM(1,5) "RTN","VAFCADT2",94,0) S HLA("HLS",7)=$$EN^VAFHLZSP(DFN,1,1) "RTN","VAFCADT2",95,0) S VAFSTR=$$COMMANUM(1,22) "RTN","VAFCADT2",96,0) S HLA("HLS",8)=$$EN^VAFHLZEL(DFN,VAFSTR,2) "RTN","VAFCADT2",97,0) S VAFSTR=$$COMMANUM(1,9) "RTN","VAFCADT2",98,0) S HLA("HLS",9)=$$EN^VAFHLZCT(DFN,VAFSTR,1) "RTN","VAFCADT2",99,0) S VAFSTR=$$COMMANUM(1,8) "RTN","VAFCADT2",100,0) S HLA("HLS",10)=$$EN^VAFHLZEM(DFN,VAFSTR,1,1) "RTN","VAFCADT2",101,0) D ALL^DGMTU21(DFN,"V",VAFHDT,"R") "RTN","VAFCADT2",102,0) S VAFSTR=$$COMMANUM(1,13) "RTN","VAFCADT2",103,0) S HLA("HLS",11)=$$EN^VAFHLZIR(+$G(DGINR("V")),VAFSTR,1) "RTN","VAFCADT2",104,0) S VAFSTR=$$COMMANUM(1,10) "RTN","VAFCADT2",105,0) S HLA("HLS",12)=$$EN^VAFHLZEN(DFN,VAFSTR,1,HL("Q"),HL("FS")) "RTN","VAFCADT2",106,0) D:$D(VATRACE) LOOP "RTN","VAFCADT2",107,0) ; "RTN","VAFCADT2",108,0) S COUNTER="" "RTN","VAFCADT2",109,0) F S COUNTER=$O(HLA("HLS",COUNTER)) Q:COUNTER'>0 D "RTN","VAFCADT2",110,0) .; I +(HLA("HLS",COUNTER))=-1 S HLERR="Bad "_COUNTER_" Segment" "RTN","VAFCADT2",111,0) . I +(HLA("HLS",COUNTER))=-1 S HL="Bad "_COUNTER_" Segment" "RTN","VAFCADT2",112,0) . "RTN","VAFCADT2",113,0) ; "RTN","VAFCADT2",114,0) EXIT ; "RTN","VAFCADT2",115,0) ;I $D(HL)=1 DO "RTN","VAFCADT2",116,0) ;. S HLERR(1)=HL "RTN","VAFCADT2",117,0) ;. D EBULL^VAFHUTL2(DFN,VAFHDT,PIVOT,"HLERR(") "RTN","VAFCADT2",118,0) I $D(HL)>1,$D(HLA("HLS")) DO "RTN","VAFCADT2",119,0) . I EVENT="A08" DO "RTN","VAFCADT2",120,0) . . D GENERATE^HLMA("VAFC ADT-A08-TSP SERVER","LM",1,.HLRST,"") "RTN","VAFCADT2",121,0) . E D GENERATE^HLMA("VAFC ADT-"_EVENT_" SERVER","LM",1,.HLRST,"") "RTN","VAFCADT2",122,0) . "RTN","VAFCADT2",123,0) D KVAR^VADPT,KVAR^VAFHLPV1 K HLA,HLERR "RTN","VAFCADT2",124,0) Q "RTN","VAFCADT2",125,0) LOOP ; "RTN","VAFCADT2",126,0) ; "RTN","VAFCADT2",127,0) ; "RTN","VAFCADT2",128,0) W !! "RTN","VAFCADT2",129,0) N XX S XX=0 "RTN","VAFCADT2",130,0) F S XX=$O(HLA("HLS",XX)) Q:XX="" W !,HLA("HLS",XX) "RTN","VAFCADT2",131,0) Q "RTN","VAFCADT2",132,0) ; "RTN","VAFCADT2",133,0) COMMANUM(FROM,TO) ;Build comma separated list of numbers "RTN","VAFCADT2",134,0) ;Input : FROM - Starting number (default = 1) "RTN","VAFCADT2",135,0) ; TO - Ending number (default = FROM) "RTN","VAFCADT2",136,0) ;Output : Comma separated list of numbers between FROM and TO "RTN","VAFCADT2",137,0) ; (Ex: 1,2,3) "RTN","VAFCADT2",138,0) ;Notes : Call assumes FROM <= TO "RTN","VAFCADT2",139,0) ; "RTN","VAFCADT2",140,0) S FROM=$G(FROM) S:(FROM="") FROM=1 "RTN","VAFCADT2",141,0) S TO=$G(TO) S:(TO="") TO=FROM "RTN","VAFCADT2",142,0) N OUTPUT,X "RTN","VAFCADT2",143,0) S OUTPUT=FROM "RTN","VAFCADT2",144,0) F X=(FROM+1):1:TO S OUTPUT=(OUTPUT_","_X) "RTN","VAFCADT2",145,0) Q OUTPUT "RTN","VAFCMSG4") 0^27^B13776310 "RTN","VAFCMSG4",1,0) VAFCMSG4 ;ALB/JRP-MESSAGE BUILDER UTILITIES ;12-SEP-1996 "RTN","VAFCMSG4",2,0) ;;5.3;Registration;**91,209,149,415**;Jun 06, 1996 "RTN","VAFCMSG4",3,0) ; "RTN","VAFCMSG4",4,0) SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for given event type "RTN","VAFCMSG4",5,0) ; "RTN","VAFCMSG4",6,0) ;Input : EVNTTYPE - Event type to build list for (Defaults to A08) "RTN","VAFCMSG4",7,0) ; Currently supported events: "RTN","VAFCMSG4",8,0) ; A04, A08, A28 "RTN","VAFCMSG4",9,0) ; SEGARRY - Array to place output in (full global reference) "RTN","VAFCMSG4",10,0) ; (Defaults to ^TMP("VAFC SEGMENTS",$J)) "RTN","VAFCMSG4",11,0) ;Output : None "RTN","VAFCMSG4",12,0) ; SEGARRY(Seq,Name) = Fields "RTN","VAFCMSG4",13,0) ; SEGARRY(Name,"BLD") = Executable code to build HL7 segment "RTN","VAFCMSG4",14,0) ; SEGARRY(Name,"CPY") = Executable code to copy HL7 segment "RTN","VAFCMSG4",15,0) ; into HL7 message "RTN","VAFCMSG4",16,0) ; SEGARRY(Name,"DEL") = Executable code to delete variables "RTN","VAFCMSG4",17,0) ; used to build HL7 segment "RTN","VAFCMSG4",18,0) ; Seq - Sequencing number to order the segments as "RTN","VAFCMSG4",19,0) ; they should be placed in the HL7 message "RTN","VAFCMSG4",20,0) ; Name - Name of HL7 segment "RTN","VAFCMSG4",21,0) ; Fields - List of fields used by segment "RTN","VAFCMSG4",22,0) ; VAFSTR would be set to this value "RTN","VAFCMSG4",23,0) ;Notes : MSH segment is not included "RTN","VAFCMSG4",24,0) ; : SEGARRY will be KILLed on entry "RTN","VAFCMSG4",25,0) ; "RTN","VAFCMSG4",26,0) ;Check input "RTN","VAFCMSG4",27,0) S EVNTTYPE=$G(EVNTTYPE) "RTN","VAFCMSG4",28,0) S:(EVNTTYPE="") EVNTTYPE="A08" "RTN","VAFCMSG4",29,0) S SEGARRY=$G(SEGARRY) "RTN","VAFCMSG4",30,0) S:(SEGARRY="") SEGARRY="^TMP(""VAFC SEGMENTS"","_$J_")" "RTN","VAFCMSG4",31,0) K @SEGARRY "RTN","VAFCMSG4",32,0) ;Declare variables "RTN","VAFCMSG4",33,0) N X,OK "RTN","VAFCMSG4",34,0) ;Check for supported event "RTN","VAFCMSG4",35,0) S OK=0 "RTN","VAFCMSG4",36,0) F X="A04","A08","A28" I X=EVNTTYPE S OK=1 Q "RTN","VAFCMSG4",37,0) Q:('OK) "RTN","VAFCMSG4",38,0) ;Segments used by A04, A08, A28 "RTN","VAFCMSG4",39,0) S @SEGARRY@(1,"EVN")="1,2,4" "RTN","VAFCMSG4",40,0) S @SEGARRY@("EVN","BLD")="D BLDEVN^VAFCMSG3" "RTN","VAFCMSG4",41,0) S @SEGARRY@("EVN","CPY")="D CPYEVN^VAFCMSG3" "RTN","VAFCMSG4",42,0) S @SEGARRY@("EVN","DEL")="D DELEVN^VAFCMSG3" "RTN","VAFCMSG4",43,0) S @SEGARRY@(2,"PID")=$$COMMANUM^VAFCADT2(1,9)_",10B,"_$$COMMANUM^VAFCADT2(11,21)_",22B,"_$$COMMANUM^VAFCADT2(23,30) "RTN","VAFCMSG4",44,0) S @SEGARRY@("PID","BLD")="D BLDPID^VAFCMSG3" "RTN","VAFCMSG4",45,0) S @SEGARRY@("PID","CPY")="D CPYPID^VAFCMSG3" "RTN","VAFCMSG4",46,0) S @SEGARRY@("PID","DEL")="D DELPID^VAFCMSG3" "RTN","VAFCMSG4",47,0) S @SEGARRY@(3,"PD1")=$$COMMANUM^VAFCADT2(1,12) "RTN","VAFCMSG4",48,0) S @SEGARRY@("PD1","BLD")="D BLDPD1^VAFCMSG3" "RTN","VAFCMSG4",49,0) S @SEGARRY@("PD1","CPY")="D CPYPD1^VAFCMSG3" "RTN","VAFCMSG4",50,0) S @SEGARRY@("PD1","DEL")="D DELPD1^VAFCMSG3" "RTN","VAFCMSG4",51,0) S @SEGARRY@(4,"PV1")="2,3,6,7,10,18,44,45,50" "RTN","VAFCMSG4",52,0) S @SEGARRY@("PV1","BLD")="D BLDPV1^VAFCMSG3" "RTN","VAFCMSG4",53,0) S @SEGARRY@("PV1","CPY")="D CPYPV1^VAFCMSG3" "RTN","VAFCMSG4",54,0) S @SEGARRY@("PV1","DEL")="D DELPV1^VAFCMSG3" "RTN","VAFCMSG4",55,0) S @SEGARRY@(5,"OBX")="" "RTN","VAFCMSG4",56,0) S @SEGARRY@("OBX","BLD")="D BLDOBX^VAFCMSG3" "RTN","VAFCMSG4",57,0) S @SEGARRY@("OBX","CPY")="D CPYOBX^VAFCMSG3" "RTN","VAFCMSG4",58,0) S @SEGARRY@("OBX","DEL")="D DELOBX^VAFCMSG3" "RTN","VAFCMSG4",59,0) S @SEGARRY@(6,"ZPD")=$$COMMANUM^VAFCADT2(1,21) "RTN","VAFCMSG4",60,0) S @SEGARRY@("ZPD","BLD")="D BLDZPD^VAFCMSG3" "RTN","VAFCMSG4",61,0) S @SEGARRY@("ZPD","CPY")="D CPYZPD^VAFCMSG3" "RTN","VAFCMSG4",62,0) S @SEGARRY@("ZPD","DEL")="D DELZPD^VAFCMSG3" "RTN","VAFCMSG4",63,0) S @SEGARRY@(7,"ZSP")="1,2,3,4,5" "RTN","VAFCMSG4",64,0) 0 S @SEGARRY@("ZSP","BLD")="D BLDZSP^VAFCMSG3" "RTN","VAFCMSG4",65,0) S @SEGARRY@("ZSP","CPY")="D CPYZSP^VAFCMSG3" "RTN","VAFCMSG4",66,0) S @SEGARRY@("ZSP","DEL")="D DELZSP^VAFCMSG3" "RTN","VAFCMSG4",67,0) S @SEGARRY@(8,"ZEL")=$$COMMANUM^VAFCADT2(1,22) "RTN","VAFCMSG4",68,0) S @SEGARRY@("ZEL","BLD")="D BLDZEL^VAFCMSG3" "RTN","VAFCMSG4",69,0) S @SEGARRY@("ZEL","CPY")="D CPYZEL^VAFCMSG3" "RTN","VAFCMSG4",70,0) S @SEGARRY@("ZEL","DEL")="D DELZEL^VAFCMSG3" "RTN","VAFCMSG4",71,0) S @SEGARRY@(9,"ZCT")="1,2,3,4,5,6,7,8,9" "RTN","VAFCMSG4",72,0) S @SEGARRY@("ZCT","BLD")="D BLDZCT^VAFCMSG3" "RTN","VAFCMSG4",73,0) S @SEGARRY@("ZCT","CPY")="D CPYZCT^VAFCMSG3" "RTN","VAFCMSG4",74,0) S @SEGARRY@("ZCT","DEL")="D DELZCT^VAFCMSG3" "RTN","VAFCMSG4",75,0) S @SEGARRY@(10,"ZEM")="1,2,3,4,5,6,7,8" "RTN","VAFCMSG4",76,0) S @SEGARRY@("ZEM","BLD")="D BLDZEM^VAFCMSG3" "RTN","VAFCMSG4",77,0) S @SEGARRY@("ZEM","CPY")="D CPYZEM^VAFCMSG3" "RTN","VAFCMSG4",78,0) S @SEGARRY@("ZEM","DEL")="D DELZEM^VAFCMSG3" "RTN","VAFCMSG4",79,0) S @SEGARRY@(11,"ZFF")="" "RTN","VAFCMSG4",80,0) S @SEGARRY@("ZFF","BLD")="D BLDZFF^VAFCMSG3" "RTN","VAFCMSG4",81,0) S @SEGARRY@("ZFF","CPY")="D CPYZFF^VAFCMSG3" "RTN","VAFCMSG4",82,0) S @SEGARRY@("ZFF","DEL")="D DELZFF^VAFCMSG3" "RTN","VAFCMSG4",83,0) S @SEGARRY@(12,"ZIR")=$$COMMANUM^VAFCADT2(1,13) "RTN","VAFCMSG4",84,0) S @SEGARRY@("ZIR","BLD")="D BLDZIR^VAFCMSG3" "RTN","VAFCMSG4",85,0) S @SEGARRY@("ZIR","CPY")="D CPYZIR^VAFCMSG3" "RTN","VAFCMSG4",86,0) S @SEGARRY@("ZIR","DEL")="D DELZIR^VAFCMSG3" "RTN","VAFCMSG4",87,0) S @SEGARRY@(13,"ZEN")=$$COMMANUM^VAFCADT2(1,10) "RTN","VAFCMSG4",88,0) S @SEGARRY@("ZEN","BLD")="D BLDZEN^VAFCMSG3" "RTN","VAFCMSG4",89,0) S @SEGARRY@("ZEN","CPY")="D CPYZEN^VAFCMSG3" "RTN","VAFCMSG4",90,0) S @SEGARRY@("ZEN","DEL")="D DELZEN^VAFCMSG3" "RTN","VAFCMSG4",91,0) Q "RTN","VAFCPID") 0^3^B12182426 "RTN","VAFCPID",1,0) VAFCPID ;ALB/MLI,PKE-Create generic PID segment ; 21 Nov 2002 3:13 PM "RTN","VAFCPID",2,0) ;;5.3;Registration;**91,149,190,415**;Aug 13, 1993 "RTN","VAFCPID",3,0) ; "RTN","VAFCPID",4,0) ; This routine returns the HL7 defined PID segment with its "RTN","VAFCPID",5,0) ; mappings to DHCP PATIENT file fields. "RTN","VAFCPID",6,0) ; "RTN","VAFCPID",7,0) EN(DFN,VAFSTR,VAFNUM) ; returns PID segment "RTN","VAFCPID",8,0) ; Input - DFN as internal entry number of the PATIENT file "RTN","VAFCPID",9,0) ; VAFSTR as string of fields requested separated by commas "RTN","VAFCPID",10,0) ; VAFNUM as sequential number for SET ID (default=1) "RTN","VAFCPID",11,0) ; "RTN","VAFCPID",12,0) ; ****Also assumes all HL7 variables returned from**** "RTN","VAFCPID",13,0) ; INIT^HLTRANS are defined "RTN","VAFCPID",14,0) ; "RTN","VAFCPID",15,0) ; Output - String containing the desired components of the PID segment "RTN","VAFCPID",16,0) ; VAFPID(n) - if the string is longer than 245, the remaining "RTN","VAFCPID",17,0) ; characters will be returned in VAFPID(n) where "RTN","VAFCPID",18,0) ; n is a sequential number beginning with 1 "RTN","VAFCPID",19,0) ; "RTN","VAFCPID",20,0) ; WARNING: This routine makes external calls to VADPT. Non-namespaced "RTN","VAFCPID",21,0) ; variables may be altered. "RTN","VAFCPID",22,0) ; "RTN","VAFCPID",23,0) N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME ; calls VADPT...have to NEW "RTN","VAFCPID",24,0) S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields "RTN","VAFCPID",25,0) S DFN=$G(DFN) "RTN","VAFCPID",26,0) I DFN']"" G QUIT "RTN","VAFCPID",27,0) D DEM^VADPT "RTN","VAFCPID",28,0) S VAFSTR=","_VAFSTR_"," "RTN","VAFCPID",29,0) K VAFY "RTN","VAFCPID",30,0) ;Set ID (#1) "RTN","VAFCPID",31,0) I VAFSTR[",1," S VAFY(1)=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFCPID",32,0) ;External ID (#2 - always included) "RTN","VAFCPID",33,0) S X=$$GETICN^MPIF001(DFN) S:(+X=-1) X="" S VAFY(2)=$S(X]"":X,1:HLQ) "RTN","VAFCPID",34,0) ;Patient ID (#3 - req) "RTN","VAFCPID",35,0) S VAFY(3)=$$M10^HLFNC(DFN) "RTN","VAFCPID",36,0) ;Alternate ID (#4) "RTN","VAFCPID",37,0) I VAFSTR[",4," S X=$G(VA("BID")),VAFY(4)=$S(X]"":X,1:HLQ) "RTN","VAFCPID",38,0) ;Name (#5 - req) "RTN","VAFCPID",39,0) S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01 "RTN","VAFCPID",40,0) S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ) "RTN","VAFCPID",41,0) ;Mother's maiden name (#6) "RTN","VAFCPID",42,0) I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ) "RTN","VAFCPID",43,0) ;Date of birth (#7) "RTN","VAFCPID",44,0) I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3)) "RTN","VAFCPID",45,0) ;Sex (#8) "RTN","VAFCPID",46,0) I VAFSTR[",8," S X=$P(VADM(5),"^",1),VAFY(8)=$S("^M^F^"[("^"_X_"^"):X,1:"U") "RTN","VAFCPID",47,0) ;Race (#10) "RTN","VAFCPID",48,0) I VAFSTR[10 D "RTN","VAFCPID",49,0) .N HOW "RTN","VAFCPID",50,0) .S Y=$F(VAFSTR,"10") "RTN","VAFCPID",51,0) .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1) "RTN","VAFCPID",52,0) .D SEQ10^VAFHLPI1(HOW,HLQ) "RTN","VAFCPID",53,0) ;Address (#11) & County (#12 - always returned with address) "RTN","VAFCPID",54,0) I VAFSTR[11 D "RTN","VAFCPID",55,0) . S X=$G(^DPT(DFN,.11)) "RTN","VAFCPID",56,0) . S X=$$ADDR($P(X,"^",1,5)_"^"_$P(X,"^",12),$P(X,"^",7)) "RTN","VAFCPID",57,0) . S Y=$P(X,HLFS,1),VAFY(11)=$S(Y]"":Y,1:HLQ) "RTN","VAFCPID",58,0) . S Y=$P(X,HLFS,2),VAFY(12)=$S(Y]"":Y,1:HLQ) "RTN","VAFCPID",59,0) S X=$G(^DPT(DFN,.13)) "RTN","VAFCPID",60,0) ;Home phone (#13) "RTN","VAFCPID",61,0) I VAFSTR[13 S X1=$$HLPHONE^HLFNC($P(X,"^",1)),VAFY(13)=$S(X1]"":X1,1:HLQ) "RTN","VAFCPID",62,0) ;Business phone (#14) "RTN","VAFCPID",63,0) I VAFSTR[14 S X1=$$HLPHONE^HLFNC($P(X,"^",2)),VAFY(14)=$S(X1]"":X1,1:HLQ) "RTN","VAFCPID",64,0) ;Marital status (#16) "RTN","VAFCPID",65,0) I VAFSTR[16 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),VAFY(16)=$S(X="M":"M",X="N":"S",X="S":"A",X]"":X,1:HLQ) "RTN","VAFCPID",66,0) ;Religious preference (#17) (if blank send 29 (UNKNOWN)) "RTN","VAFCPID",67,0) I VAFSTR[17 S X=$P($G(^DIC(13,+VADM(9),0)),"^",4),VAFY(17)=$S(X]"":X,1:29) "RTN","VAFCPID",68,0) ;SSN (#19) "RTN","VAFCPID",69,0) I VAFSTR[19 S X=$P(VADM(2),"^",1),VAFY(19)=$S(X]"":X,1:HLQ) "RTN","VAFCPID",70,0) ;Ethnicity (#22) "RTN","VAFCPID",71,0) I VAFSTR[22 D "RTN","VAFCPID",72,0) .N HOW "RTN","VAFCPID",73,0) .S Y=$F(VAFSTR,"22") "RTN","VAFCPID",74,0) .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1) "RTN","VAFCPID",75,0) .D SEQ22^VAFHLPI1(HOW,HLQ) "RTN","VAFCPID",76,0) ;Birth place (#23) "RTN","VAFCPID",77,0) I VAFSTR[23 D "RTN","VAFCPID",78,0) .N DGBC,DGBS "RTN","VAFCPID",79,0) .S DGBC=$$GET1^DIQ(2,DFN,.092,"I") "RTN","VAFCPID",80,0) .S DGBS=$$GET1^DIQ(2,DFN,.093,"E") "RTN","VAFCPID",81,0) .S VAFY(23)=DGBC_" "_DGBS "RTN","VAFCPID",82,0) ;Date of death (#29) & Death indicator (#30) (always included if dead) "RTN","VAFCPID",83,0) S X=+VADM(6) I X D "RTN","VAFCPID",84,0) .S VAFY(29)=$$HLDATE^HLFNC(X) "RTN","VAFCPID",85,0) .S VAFY(30)="Y" "RTN","VAFCPID",86,0) ; "RTN","VAFCPID",87,0) QUIT D KVA^VADPT "RTN","VAFCPID",88,0) D MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID) "RTN","VAFCPID",89,0) Q OUTPUT "RTN","VAFCPID",90,0) ; "RTN","VAFCPID",91,0) ADDR(VAFADDR,VAFCOUNT) ;Return HL7 address "RTN","VAFCPID",92,0) ; Input - VAFADDR as address in format: "RTN","VAFCPID",93,0) ; line1^line2^line3^city^state^zip+4 "RTN","VAFCPID",94,0) ; VAFCOUNT as internal value of county (optional) "RTN","VAFCPID",95,0) ; Output - HL7 v2.3 formatted Address_HLFS_County Code "RTN","VAFCPID",96,0) ; "RTN","VAFCPID",97,0) ; ****Also assumes all HL7 variables returned from**** "RTN","VAFCPID",98,0) ; INIT^HLTRANS are defined "RTN","VAFCPID",99,0) ; "RTN","VAFCPID",100,0) N X,Y,Z S X=$E(HLECH) "RTN","VAFCPID",101,0) ;Street address (line 1) "RTN","VAFCPID",102,0) S $P(Y,X,1)=$P(VAFADDR,"^",1) "RTN","VAFCPID",103,0) ;Other designation (line 2) "RTN","VAFCPID",104,0) S $P(Y,X,2)=$P(VAFADDR,"^",2) "RTN","VAFCPID",105,0) ;City "RTN","VAFCPID",106,0) S $P(Y,X,3)=$P(VAFADDR,"^",4) "RTN","VAFCPID",107,0) ;State "RTN","VAFCPID",108,0) S $P(Y,X,4)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),0)),"^",2) "RTN","VAFCPID",109,0) ;Zip "RTN","VAFCPID",110,0) S $P(Y,X,5)=$P(VAFADDR,"^",6) "RTN","VAFCPID",111,0) ;Other geographic designation (line 3) "RTN","VAFCPID",112,0) S $P(Y,X,8)=$P(VAFADDR,"^",3) "RTN","VAFCPID",113,0) ;County "RTN","VAFCPID",114,0) S $P(Y,X,9)=$P($G(^DIC(5,+$P(VAFADDR,"^",5),1,+$G(VAFCOUNT),0)),"^",3) "RTN","VAFCPID",115,0) F Z=1,2,3,4,5,8,9 I $P(Y,X,Z)="" S $P(Y,X,Z)=HLQ "RTN","VAFCPID",116,0) I $G(VAFCOUNT) D "RTN","VAFCPID",117,0) .S $P(Y,HLFS,2)=$P(Y,X,9) "RTN","VAFCPID",118,0) Q Y "RTN","VAFHBGJ") 0^23^B4103720 "RTN","VAFHBGJ",1,0) VAFHBGJ ;ALB/CM BACKGROUND JOB FOR UPDATE MESSAGES ;05/23/95 "RTN","VAFHBGJ",2,0) ;;5.3;Registration;**91,415**;Jun 06, 1996 "RTN","VAFHBGJ",3,0) ; "RTN","VAFHBGJ",4,0) ;This routine will loop through the pivot file, getting the entries "RTN","VAFHBGJ",5,0) ;that have the TRANSMITTED-NEED TO TRANSMIT field populated and "RTN","VAFHBGJ",6,0) ; generating an A08 message for the update. "RTN","VAFHBGJ",7,0) ; "RTN","VAFHBGJ",8,0) ; "RTN","VAFHBGJ",9,0) EN ;check to see if sending is on or off "RTN","VAFHBGJ",10,0) I '$$SEND^VAFHUTL() Q "RTN","VAFHBGJ",11,0) ;make sure only one job will run "RTN","VAFHBGJ",12,0) ENT L +^XTMP("ADT/HL7 VAFH BATCH UPDATE"):3 E Q "RTN","VAFHBGJ",13,0) ; "RTN","VAFHBGJ",14,0) D MAIN "RTN","VAFHBGJ",15,0) K HLA D KILL^HLTRANS "RTN","VAFHBGJ",16,0) L -^XTMP("ADT/HL7 VAFH BATCH UPDATE") "RTN","VAFHBGJ",17,0) Q "RTN","VAFHBGJ",18,0) ; "RTN","VAFHBGJ",19,0) MAIN N LSTR,LOOP,NODE,DFN,RECENT,EVTY,EVDT,PIVOT,VPTR,GBL,COUNT,UP,ERR,CLEAN "RTN","VAFHBGJ",20,0) I '$O(^VAT(391.71,"AC",1,"")) Q "RTN","VAFHBGJ",21,0) S LOOP="",GBL="HLA(""HLS"")" "RTN","VAFHBGJ",22,0) K HLA "RTN","VAFHBGJ",23,0) ; "RTN","VAFHBGJ",24,0) F S COUNT=1,LOOP=$O(^VAT(391.71,"AC",1,LOOP)) Q:LOOP="" D Q:$D(HL)=1 "RTN","VAFHBGJ",25,0) .; bad x-ref, delete it and quit "RTN","VAFHBGJ",26,0) .I '$D(^VAT(391.71,LOOP)) K ^VAT(391.71,"AC",1,LOOP) Q "RTN","VAFHBGJ",27,0) .S NODE=$G(^VAT(391.71,LOOP,0)) Q:'NODE "RTN","VAFHBGJ",28,0) .K HL D INIT^HLFNC2("VAFH A08",.HL) "RTN","VAFHBGJ",29,0) .I $D(HL)=1 Q "RTN","VAFHBGJ",30,0) .I LOOP#10=0,+$$S^%ZTLOAD K HL S HL="TaskMan User Stop " Q "RTN","VAFHBGJ",31,0) .S DFN=$P(NODE,"^",3),PIVOT=$P(NODE,"^",2) Q:'DFN "RTN","VAFHBGJ",32,0) .; need to check if anything but registration "RTN","VAFHBGJ",33,0) .S LSTR=$P($$LTD^VAFHUTL(DFN),"^",2) "RTN","VAFHBGJ",34,0) .I LSTR'="R",LSTR'["No l" S LSTR=",2,50" "RTN","VAFHBGJ",35,0) .E S LSTR=50 "RTN","VAFHBGJ",36,0) .; "RTN","VAFHBGJ",37,0) .; generate the a08 message "RTN","VAFHBGJ",38,0) .S ERR=$$UP^VAFHCA08(DFN,PIVOT,NODE,COUNT,GBL,"2,3,4,5,6,7,8,9,10B,11,12,13,14,16,19,22B","2,3,4,5,6,7,8,9,10,11,12,13,14,15",LSTR) "RTN","VAFHBGJ",39,0) .I +ERR=0 DO "RTN","VAFHBGJ",40,0) . .S CLEAN=$$CLNTRAN^VAFHPIV2(PIVOT),COUNT=$P(ERR,"^",2)+1 "RTN","VAFHBGJ",41,0) .E Q "RTN","VAFHBGJ",42,0) .;;;I COUNT<2&($D(CLEAN)) D "RTN","VAFHBGJ",43,0) .I +CLEAN=-1 D ERROR^VAFHCCAP(CLEAN,DFN) Q "RTN","VAFHBGJ",44,0) .D GENERATE^HLMA("VAFH A08","LM",1,.HLRESLT) "RTN","VAFHBGJ",45,0) .K HLA "RTN","VAFHBGJ",46,0) Q "RTN","VAFHLPI1") 0^2^B22032319 "RTN","VAFHLPI1",1,0) VAFHLPI1 ;BPFO/JRP - EXTENSION OF PID SEGMENT BUILDER VAFHLPID;5-DEC-2001 ; 21 Nov 2002 3:13 PM "RTN","VAFHLPI1",2,0) ;;5.3;Registration;**415**;Aug 13, 1993 "RTN","VAFHLPI1",3,0) ; "RTN","VAFHLPI1",4,0) Q "RTN","VAFHLPI1",5,0) ; "RTN","VAFHLPI1",6,0) SEQ3(DFN,TYPE,HLENC,HLQ) ;Build specified Patient ID (seq 3) "RTN","VAFHLPI1",7,0) ;Input : DFN - Pointer to Patient file (#2) "RTN","VAFHLPI1",8,0) ; TYPE - Which Patient ID to build "RTN","VAFHLPI1",9,0) ; NI = ICN (default) "RTN","VAFHLPI1",10,0) ; SS = SSN [with dashes] "RTN","VAFHLPI1",11,0) ; PI = DFN "RTN","VAFHLPI1",12,0) ; HLENC - HL7 encoding characters (defaults to ~|\&) "RTN","VAFHLPI1",13,0) ; HLQ - HL7 null designation (defaults to "") "RTN","VAFHLPI1",14,0) ;Output : Value for Patient ID (seq 3) "RTN","VAFHLPI1",15,0) ;Notes : HLQ will be returned on bad input "RTN","VAFHLPI1",16,0) ; "RTN","VAFHLPI1",17,0) ;Check input "RTN","VAFHLPI1",18,0) S HLENC=$G(HLENC) "RTN","VAFHLPI1",19,0) S:$L(HLENC)'=4 HLENC="~|\&" "RTN","VAFHLPI1",20,0) S:'$D(HLQ) HLQ="""""" "RTN","VAFHLPI1",21,0) S DFN=+$G(DFN) "RTN","VAFHLPI1",22,0) I '$D(^DPT(DFN,0)) Q HLQ "RTN","VAFHLPI1",23,0) S TYPE=$G(TYPE,"NI") "RTN","VAFHLPI1",24,0) S:(",NI,SS,PI,"'[(","_TYPE_",")) TYPE="NI" "RTN","VAFHLPI1",25,0) ;Declare variables "RTN","VAFHLPI1",26,0) N COMP,REP,SUB,VALUE,ID,TMP "RTN","VAFHLPI1",27,0) ;Break out encoding characters "RTN","VAFHLPI1",28,0) S COMP=$E(HLENC,1) "RTN","VAFHLPI1",29,0) S REP=$E(HLENC,2) "RTN","VAFHLPI1",30,0) S SUB=$E(HLENC,4) "RTN","VAFHLPI1",31,0) ;ID (comp 1) "RTN","VAFHLPI1",32,0) S ID="" "RTN","VAFHLPI1",33,0) ;ICN "RTN","VAFHLPI1",34,0) I TYPE="NI" D "RTN","VAFHLPI1",35,0) .;Don't transmit local ICNs "RTN","VAFHLPI1",36,0) .I $$IFLOCAL^MPIF001(DFN) S ID="" Q "RTN","VAFHLPI1",37,0) .S ID=$$GETICN^MPIF001(DFN) "RTN","VAFHLPI1",38,0) .I (+ID)=-1 S ID="" "RTN","VAFHLPI1",39,0) ;SSN "RTN","VAFHLPI1",40,0) I TYPE="SS" D "RTN","VAFHLPI1",41,0) .S ID=$P($G(^DPT(DFN,0)),"^",9) "RTN","VAFHLPI1",42,0) .I ID'="" S ID=$E(ID,1,3)_"-"_$E(ID,4,5)_"-"_$E(ID,6,10) "RTN","VAFHLPI1",43,0) ;DFN "RTN","VAFHLPI1",44,0) I TYPE="PI" D "RTN","VAFHLPI1",45,0) .S ID=DFN "RTN","VAFHLPI1",46,0) S VALUE=$S(ID="":HLQ,1:ID) "RTN","VAFHLPI1",47,0) ;Check Digit (comp 2) - not used for SSN "RTN","VAFHLPI1",48,0) I TYPE'="SS" D "RTN","VAFHLPI1",49,0) .;ICN - pull off check digit "RTN","VAFHLPI1",50,0) .I TYPE="NI" S $P(VALUE,COMP,2)=$P(ID,"V",2) Q "RTN","VAFHLPI1",51,0) .;DFN - calculate check digit "RTN","VAFHLPI1",52,0) .; Note: output of call includes Check Digit Scheme (comp 3) "RTN","VAFHLPI1",53,0) .S TMP=$$M10^HLFNC(DFN,COMP) "RTN","VAFHLPI1",54,0) .S $P(VALUE,COMP,2,3)=$P(TMP,COMP,2,3) "RTN","VAFHLPI1",55,0) ;Assigning Authority (comp 4) "RTN","VAFHLPI1",56,0) S TMP="" "RTN","VAFHLPI1",57,0) S $P(TMP,SUB,1)=$S(TYPE="SS":"USSSA",1:"USVHA") "RTN","VAFHLPI1",58,0) S $P(TMP,SUB,3)="L" "RTN","VAFHLPI1",59,0) S $P(VALUE,COMP,4)=TMP "RTN","VAFHLPI1",60,0) ;Identifier Type Code (comp 5) "RTN","VAFHLPI1",61,0) S $P(VALUE,COMP,5)=TYPE "RTN","VAFHLPI1",62,0) ;Assigning Facility (comp 6) - only used for DFN "RTN","VAFHLPI1",63,0) I TYPE="PI" S $P(VALUE,COMP,6)=+$P($$SITE^VASITE(),"^",3) "RTN","VAFHLPI1",64,0) ;Effective Date (comp 7) - only used for DFN "RTN","VAFHLPI1",65,0) I TYPE="PI" D "RTN","VAFHLPI1",66,0) .;DFN "RTN","VAFHLPI1",67,0) .S TMP=$P($G(^DPT(DFN,0)),"^",16) "RTN","VAFHLPI1",68,0) .S $P(VALUE,COMP,7)=$$HLDATE^HLFNC(TMP,"DT") "RTN","VAFHLPI1",69,0) ;Return value "RTN","VAFHLPI1",70,0) Q VALUE "RTN","VAFHLPI1",71,0) ; "RTN","VAFHLPI1",72,0) SEQ10(HOW,HLQ) ;Race "RTN","VAFHLPI1",73,0) ;Input : HOW - Qualifiers denoting how & which race to return "RTN","VAFHLPI1",74,0) ; N = Return new race value (2.02 multiple) "RTN","VAFHLPI1",75,0) ; T = Include text (components 2 & 5) "RTN","VAFHLPI1",76,0) ; B = Include second triplet (components 4 - 6) "RTN","VAFHLPI1",77,0) ; "" = Return historical value (.06 field) "RTN","VAFHLPI1",78,0) ; HLQ - HL7 null designation "RTN","VAFHLPI1",79,0) ;Assumed: VADM() - Output of call to DEM^VADPT "RTN","VAFHLPI1",80,0) ;Output : None - sets nodes in array VAFY "RTN","VAFHLPI1",81,0) ; VAFY(10,1..X) = Repetion X (if no components) "RTN","VAFHLPI1",82,0) ; VAFY(10,1..X,1..Y) = Component Y of repetiton X "RTN","VAFHLPI1",83,0) ;Notes : Validity and existance of input is assumed "RTN","VAFHLPI1",84,0) ; : Use of T & B qualifiers assume use of N qualifier "RTN","VAFHLPI1",85,0) ; : Assumes no individual component is greater than 245 "RTN","VAFHLPI1",86,0) ; characters long "RTN","VAFHLPI1",87,0) ; "RTN","VAFHLPI1",88,0) ;Declare variables "RTN","VAFHLPI1",89,0) N RACENUM,CNT,RACE,X "RTN","VAFHLPI1",90,0) K VAFY(10) "RTN","VAFHLPI1",91,0) I (HOW="")!((HOW'["N")&(HOW'["B")&(HOW'["T")) D Q "RTN","VAFHLPI1",92,0) .;Send historical value (if blank, send 7 (UNKNOWN)) "RTN","VAFHLPI1",93,0) .S X=$$PTR2CODE^DGUTL4(+VADM(8),1,1) "RTN","VAFHLPI1",94,0) .S VAFY(10,1)=$S(X]"":X,1:7) "RTN","VAFHLPI1",95,0) ;No values on file "RTN","VAFHLPI1",96,0) I VADM(12)=0 D Q "RTN","VAFHLPI1",97,0) .;First triplet "RTN","VAFHLPI1",98,0) .S VAFY(10,1,1)=HLQ "RTN","VAFHLPI1",99,0) .S VAFY(10,1,2)=$S(HOW["T":HLQ,1:"") "RTN","VAFHLPI1",100,0) .S VAFY(10,1,3)="0005" "RTN","VAFHLPI1",101,0) .;Second triplet "RTN","VAFHLPI1",102,0) .Q:HOW'["B" "RTN","VAFHLPI1",103,0) .S VAFY(10,1,4)=HLQ "RTN","VAFHLPI1",104,0) .S VAFY(10,1,5)=$S(HOW["T":HLQ,1:"") "RTN","VAFHLPI1",105,0) .S VAFY(10,1,6)="CDC" "RTN","VAFHLPI1",106,0) ;Loop through all races (CNT is repetition location) "RTN","VAFHLPI1",107,0) S RACENUM=0 "RTN","VAFHLPI1",108,0) F CNT=1:1 S RACENUM=+$O(VADM(12,RACENUM)) Q:'RACENUM D "RTN","VAFHLPI1",109,0) .;Fabricate race value -> RACE-METHOD "RTN","VAFHLPI1",110,0) .S RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2) "RTN","VAFHLPI1",111,0) .S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,RACENUM,1)),3,2) "RTN","VAFHLPI1",112,0) .S:X="" X="UNK" "RTN","VAFHLPI1",113,0) .S RACE=RACE_"-"_X "RTN","VAFHLPI1",114,0) .;First triplet "RTN","VAFHLPI1",115,0) .S VAFY(10,CNT,1)=RACE "RTN","VAFHLPI1",116,0) .S VAFY(10,CNT,2)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"") "RTN","VAFHLPI1",117,0) .S VAFY(10,CNT,3)="0005" "RTN","VAFHLPI1",118,0) .;Second triplet "RTN","VAFHLPI1",119,0) .Q:HOW'["B" "RTN","VAFHLPI1",120,0) .S X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3) "RTN","VAFHLPI1",121,0) .S VAFY(10,CNT,4)=$S(X="":HLQ,1:X) "RTN","VAFHLPI1",122,0) .S VAFY(10,CNT,5)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"") "RTN","VAFHLPI1",123,0) .S VAFY(10,CNT,6)="CDC" "RTN","VAFHLPI1",124,0) Q "RTN","VAFHLPI1",125,0) ; "RTN","VAFHLPI1",126,0) SEQ22(HOW,HLQ) ;Ethnicity "RTN","VAFHLPI1",127,0) ;Input : HOW - Qualifiers denoting how to return ethnicity "RTN","VAFHLPI1",128,0) ; T = Include text (components 2 & 5) "RTN","VAFHLPI1",129,0) ; B = Include second triplet (components 4 - 6) "RTN","VAFHLPI1",130,0) ; "" = Only return components 1 & 3 "RTN","VAFHLPI1",131,0) ; HLQ - HL7 null designation "RTN","VAFHLPI1",132,0) ;Assumed: VADM() - Output of call to DEM^VADPT "RTN","VAFHLPI1",133,0) ;Output : None - sets nodes in array VAFY "RTN","VAFHLPI1",134,0) ; VAFY(22,1,1..Y) = Component Y "RTN","VAFHLPI1",135,0) ;Notes : Validity and existance of input is assumed "RTN","VAFHLPI1",136,0) ; : Assumes no individual component is greater than 245 "RTN","VAFHLPI1",137,0) ; characters long "RTN","VAFHLPI1",138,0) ; "RTN","VAFHLPI1",139,0) ;Declare variables "RTN","VAFHLPI1",140,0) N ETHNIC,X,ETHNUM,CNT "RTN","VAFHLPI1",141,0) K VAFY(22) "RTN","VAFHLPI1",142,0) ;No value on file "RTN","VAFHLPI1",143,0) I +VADM(11)=0 D Q "RTN","VAFHLPI1",144,0) .;First triplet "RTN","VAFHLPI1",145,0) .S VAFY(22,1,1)=HLQ "RTN","VAFHLPI1",146,0) .S VAFY(22,1,2)=$S(HOW["T":HLQ,1:"") "RTN","VAFHLPI1",147,0) .S VAFY(22,1,3)="0189" "RTN","VAFHLPI1",148,0) .;Second triplet "RTN","VAFHLPI1",149,0) .Q:HOW'["B" "RTN","VAFHLPI1",150,0) .S VAFY(22,1,4)=HLQ "RTN","VAFHLPI1",151,0) .S VAFY(22,1,5)=$S(HOW["T":HLQ,1:"") "RTN","VAFHLPI1",152,0) .S VAFY(22,1,6)="CDC" "RTN","VAFHLPI1",153,0) ;Loop through all ethnicities (CNT is repetition location) "RTN","VAFHLPI1",154,0) S ETHNUM=0 "RTN","VAFHLPI1",155,0) F CNT=1:1 S ETHNUM=+$O(VADM(11,ETHNUM)) Q:'ETHNUM D "RTN","VAFHLPI1",156,0) .;Fabricate ethnicity value -> ETHNICITY-METHOD "RTN","VAFHLPI1",157,0) .S ETHNIC=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,2) "RTN","VAFHLPI1",158,0) .S X=$$PTR2CODE^DGUTL4(+$G(VADM(11,ETHNUM,1)),3,2) "RTN","VAFHLPI1",159,0) .S:X="" X="UNK" "RTN","VAFHLPI1",160,0) .S ETHNIC=ETHNIC_"-"_X "RTN","VAFHLPI1",161,0) .;First triplet "RTN","VAFHLPI1",162,0) .S VAFY(22,CNT,1)=ETHNIC "RTN","VAFHLPI1",163,0) .S VAFY(22,CNT,2)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"") "RTN","VAFHLPI1",164,0) .S VAFY(22,CNT,3)="0189" "RTN","VAFHLPI1",165,0) .;Second triplet "RTN","VAFHLPI1",166,0) .Q:HOW'["B" "RTN","VAFHLPI1",167,0) .S X=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,3) "RTN","VAFHLPI1",168,0) .S VAFY(22,CNT,4)=$S(X="":HLQ,1:X) "RTN","VAFHLPI1",169,0) .S VAFY(22,CNT,5)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"") "RTN","VAFHLPI1",170,0) .S VAFY(22,CNT,6)="CDC" "RTN","VAFHLPI1",171,0) Q "RTN","VAFHLPID") 0^1^B9502545 "RTN","VAFHLPID",1,0) VAFHLPID ;ALB/MLI/ESD - Create generic PID segment ; 21 Nov 2002 3:13 PM "RTN","VAFHLPID",2,0) ;;5.3;Registration;**68,94,415**;Aug 13, 1993 "RTN","VAFHLPID",3,0) ; "RTN","VAFHLPID",4,0) ; This routine returns the HL7 defined PID segment with its "RTN","VAFHLPID",5,0) ; mappings to DHCP PATIENT file fields. "RTN","VAFHLPID",6,0) ; "RTN","VAFHLPID",7,0) EN(DFN,VAFSTR,VAFNUM,PTID) ; returns PID segment "RTN","VAFHLPID",8,0) ; Input - DFN as internal entry number of the PATIENT file "RTN","VAFHLPID",9,0) ; VAFSTR as string of fields requested separated by commas "RTN","VAFHLPID",10,0) ; VAFNUM as sequential number for SET ID (default=1) "RTN","VAFHLPID",11,0) ; PTID is flag denoting which Patient ID (seq 3) to use "RTN","VAFHLPID",12,0) ; 0 - Use DFN formatted as data type CK (default) "RTN","VAFHLPID",13,0) ; 1 - Use ICN "RTN","VAFHLPID",14,0) ; 2 - Use DFN formatted as data type CX "RTN","VAFHLPID",15,0) ; 3 - Use SSN (with dashes) "RTN","VAFHLPID",16,0) ; "RTN","VAFHLPID",17,0) ; ****Also assumes all HL7 variables returned from**** "RTN","VAFHLPID",18,0) ; INIT^HLTRANS are defined "RTN","VAFHLPID",19,0) ; "RTN","VAFHLPID",20,0) ; Output - String containing the desired components of the PID segment "RTN","VAFHLPID",21,0) ; VAFPID(n) - if the string is longer than 245, the remaining "RTN","VAFHLPID",22,0) ; characters will be returned in VAFPID(n) where "RTN","VAFHLPID",23,0) ; n is a sequential number beginning with 1 "RTN","VAFHLPID",24,0) ; "RTN","VAFHLPID",25,0) ; WARNING: This routine makes external calls to VADPT. Non-namespaced "RTN","VAFHLPID",26,0) ; variables may be altered. "RTN","VAFHLPID",27,0) ; "RTN","VAFHLPID",28,0) N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME ; calls VADPT...have to NEW "RTN","VAFHLPID",29,0) S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields "RTN","VAFHLPID",30,0) S DFN=$G(DFN) "RTN","VAFHLPID",31,0) I DFN']"" G QUIT "RTN","VAFHLPID",32,0) D DEM^VADPT "RTN","VAFHLPID",33,0) S VAFSTR=","_VAFSTR_"," "RTN","VAFHLPID",34,0) K VAFY "RTN","VAFHLPID",35,0) ;Set ID (#1) "RTN","VAFHLPID",36,0) I VAFSTR[",1," S VAFY(1)=$S($G(VAFNUM):VAFNUM,1:1) "RTN","VAFHLPID",37,0) ;External ID (#2) "RTN","VAFHLPID",38,0) I VAFSTR[",2," S X=$G(VA("PID")),VAFY(2)=$S(X]"":$$M10^HLFNC(X),1:HLQ) "RTN","VAFHLPID",39,0) ;Patient ID (#3 - req) "RTN","VAFHLPID",40,0) S PTID=+$G(PTID) "RTN","VAFHLPID",41,0) I 'PTID S VAFY(3)=$$M10^HLFNC(DFN) "RTN","VAFHLPID",42,0) I PTID D "RTN","VAFHLPID",43,0) .S X=$S(PTID=1:"NI",PTID=2:"PI",PTID=3:"SS") "RTN","VAFHLPID",44,0) .S VAFY(3)=$$SEQ3^VAFHLPI1(DFN,X,HLECH,HLQ) "RTN","VAFHLPID",45,0) ;Alternate ID (#4) "RTN","VAFHLPID",46,0) I VAFSTR[",4," S X=$G(VA("BID")),VAFY(4)=$S(X]"":X,1:HLQ) "RTN","VAFHLPID",47,0) ;Name (#5 - req) "RTN","VAFHLPID",48,0) S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01 "RTN","VAFHLPID",49,0) S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ) "RTN","VAFHLPID",50,0) ;Mother's maiden name (#6) "RTN","VAFHLPID",51,0) I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ) "RTN","VAFHLPID",52,0) ;Date of birth (#7) "RTN","VAFHLPID",53,0) I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3)) "RTN","VAFHLPID",54,0) ;Sex (#8) "RTN","VAFHLPID",55,0) I VAFSTR[",8," S X=$P(VADM(5),"^",1),VAFY(8)=$S("^M^F^"[("^"_X_"^"):X,1:"U") "RTN","VAFHLPID",56,0) ;Race (#10) "RTN","VAFHLPID",57,0) I VAFSTR[10 D "RTN","VAFHLPID",58,0) .N HOW "RTN","VAFHLPID",59,0) .S Y=$F(VAFSTR,"10") "RTN","VAFHLPID",60,0) .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1) "RTN","VAFHLPID",61,0) .D SEQ10^VAFHLPI1(HOW,HLQ) "RTN","VAFHLPID",62,0) ;Address (#11) and County (#12) "RTN","VAFHLPID",63,0) I VAFSTR[11!(VAFSTR[12) D "RTN","VAFHLPID",64,0) . S X=$G(^DPT(DFN,.11)) "RTN","VAFHLPID",65,0) . S X=$$ADDR^VAFHLFNC($P(X,"^",1,5)_"^"_$P(X,"^",12),$P(X,"^",7)) "RTN","VAFHLPID",66,0) . I VAFSTR[11 S Y=$P(X,HLFS,1),VAFY(11)=$S(Y]"":Y,1:HLQ) "RTN","VAFHLPID",67,0) . I VAFSTR[12 S Y=$P(X,HLFS,2),VAFY(12)=$S(Y]"":Y,1:HLQ) "RTN","VAFHLPID",68,0) S X=$G(^DPT(DFN,.13)) "RTN","VAFHLPID",69,0) ;Home phone (#13) "RTN","VAFHLPID",70,0) I VAFSTR[13 S X1=$$HLPHONE^HLFNC($P(X,"^",1)),VAFY(13)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLPID",71,0) ;Business phone (#14) "RTN","VAFHLPID",72,0) I VAFSTR[14 S X1=$$HLPHONE^HLFNC($P(X,"^",2)),VAFY(14)=$S(X1]"":X1,1:HLQ) "RTN","VAFHLPID",73,0) ;Marital status (#16) "RTN","VAFHLPID",74,0) I VAFSTR[16 S X=$P($G(^DIC(11,+VADM(10),0)),"^",3),VAFY(16)=$S(X="N":"S",X="U":"",X="":HLQ,1:X) "RTN","VAFHLPID",75,0) ;Religious preference (#17) (if blank send 29 (UNKNOWN)) "RTN","VAFHLPID",76,0) I VAFSTR[17 S X=$P($G(^DIC(13,+VADM(9),0)),"^",4),VAFY(17)=$S(X]"":X,1:29) "RTN","VAFHLPID",77,0) ;SSN (#19) "RTN","VAFHLPID",78,0) I VAFSTR[19 S X=$P(VADM(2),"^",1),VAFY(19)=$S(X]"":X,1:HLQ) "RTN","VAFHLPID",79,0) ;Ethnicity (#22) "RTN","VAFHLPID",80,0) I VAFSTR[22 D "RTN","VAFHLPID",81,0) .N HOW "RTN","VAFHLPID",82,0) .S Y=$F(VAFSTR,"22") "RTN","VAFHLPID",83,0) .S HOW=$P($E(VAFSTR,Y,$F(VAFSTR,",",Y)),",",1) "RTN","VAFHLPID",84,0) .D SEQ22^VAFHLPI1(HOW,HLQ) "RTN","VAFHLPID",85,0) ; "RTN","VAFHLPID",86,0) QUIT D KVA^VADPT "RTN","VAFHLPID",87,0) D MAKEIT^VAFHLU("PID",.VAFY,.OUTPUT,.VAFPID) "RTN","VAFHLPID",88,0) Q OUTPUT "RTN","VAFHLU") 0^4^B2213135 "RTN","VAFHLU",1,0) VAFHLU ;BPFO/JRP - SEGMENT BUILDING UTILTIES ;7/12/2002 "RTN","VAFHLU",2,0) ;;5.3;Registration;**415**;Aug 13, 1993 "RTN","VAFHLU",3,0) ; "RTN","VAFHLU",4,0) Q "RTN","VAFHLU",5,0) MAKEIT(SEGNAME,SEGARR,FIRST245,ADTLNODE) ;Make segment "RTN","VAFHLU",6,0) ;Input : SEGNAME - Name of segment being built "RTN","VAFHLU",7,0) ; SEGARR - Array continue segment data (pass by value) "RTN","VAFHLU",8,0) ; SEGARR(X) = Value for sequence N "RTN","VAFHLU",9,0) ; SEGARR(X,Y) = Repetition Y of sequence X "RTN","VAFHLU",10,0) ; SEGARR(X,Y,Z) = Component Z of repetition Y of sequence X "RTN","VAFHLU",11,0) ; FIRST245 - Variable to return first 245 characters of "RTN","VAFHLU",12,0) ; segment in (pass by value) "RTN","VAFHLU",13,0) ; ADTLNODE - Array for continuation nodes (pass by value) "RTN","VAFHLU",14,0) ;Assumed: HL7 encoding chars (output of INIT^HLFNC2 or INIT^HLTRANS) "RTN","VAFHLU",15,0) ;Output : None "RTN","VAFHLU",16,0) ; FIRST245 = First 245 characters of segment "RTN","VAFHLU",17,0) ; ADTLNODE(1..n) = Continuation of segment "RTN","VAFHLU",18,0) ;Notes : Validity & existance of input is assumed "RTN","VAFHLU",19,0) ; : Assumes no single element contained in SEGARR is greater "RTN","VAFHLU",20,0) ; than 245 characters "RTN","VAFHLU",21,0) ; : Segment is broken at field/repetition/component boundaries "RTN","VAFHLU",22,0) ; (based on the level of detail within SEGARR) "RTN","VAFHLU",23,0) ; "RTN","VAFHLU",24,0) ;Declare variables "RTN","VAFHLU",25,0) N SUB1,SUB2,SUB3,CS,RS,FS,OUTREF "RTN","VAFHLU",26,0) K FIRST245,ADTLNODE "RTN","VAFHLU",27,0) ;Get HL7 separators (attempts to use HL() array) "RTN","VAFHLU",28,0) S FS=$S($D(HL("FS")):HL("FS"),1:HLFS) "RTN","VAFHLU",29,0) S X=$S($D(HL("ECH")):HL("ECH"),1:HLECH),CS=$E(X,1),RS=$E(X,2) "RTN","VAFHLU",30,0) ;Build output "RTN","VAFHLU",31,0) S OUTREF=$NA(FIRST245) "RTN","VAFHLU",32,0) S @OUTREF=SEGNAME "RTN","VAFHLU",33,0) I '$O(SEGARR("")) S X="",Y=FS D ADD Q "RTN","VAFHLU",34,0) F SUB1=1:1:$O(SEGARR(""),-1) D "RTN","VAFHLU",35,0) .S X=$G(SEGARR(SUB1)),Y=FS D ADD "RTN","VAFHLU",36,0) .F SUB2=1:1:$O(SEGARR(SUB1,""),-1) D "RTN","VAFHLU",37,0) ..S X=$G(SEGARR(SUB1,SUB2)),Y=$S(SUB2=1:"",1:RS) D ADD "RTN","VAFHLU",38,0) ..F SUB3=1:1:$O(SEGARR(SUB1,SUB2,""),-1) D "RTN","VAFHLU",39,0) ...S X=$G(SEGARR(SUB1,SUB2,SUB3)),Y=$S(SUB3=1:"",1:CS) D ADD "RTN","VAFHLU",40,0) Q "RTN","VAFHLU",41,0) ADD ;Add to output - account for continuation node "RTN","VAFHLU",42,0) I ($L(@OUTREF)+$L(X)+1)>245 D "RTN","VAFHLU",43,0) .S X1=1+$O(ADTLNODE(""),-1) "RTN","VAFHLU",44,0) .S OUTREF=$NA(ADTLNODE(X1)) "RTN","VAFHLU",45,0) .S @OUTREF="" "RTN","VAFHLU",46,0) S @OUTREF=@OUTREF_Y_X "RTN","VAFHLU",47,0) Q "RTN","VAFHQRY") 0^24^B3246580 "RTN","VAFHQRY",1,0) VAFHQRY ;ALB/RJS - MCCR DATA CAPTURE HANDLES QUERY MESSAGES ; 6/7/95 "RTN","VAFHQRY",2,0) ;;5.3;Registration;**91,415**;Jun 06, 1996 "RTN","VAFHQRY",3,0) ;;HL7v1.6 "RTN","VAFHQRY",4,0) ; "RTN","VAFHQRY",5,0) ; THIS ROUTINE HANDLES THE QUERY MESSAGES FOR THE HL7 ADT "RTN","VAFHQRY",6,0) ; PROJECT "RTN","VAFHQRY",7,0) ; "RTN","VAFHQRY",8,0) ; INPUT IS THE IEN OF THE MESSAGE IN THE ^HL(772 GLOBAL, "HLDA" "RTN","VAFHQRY",9,0) ; "RTN","VAFHQRY",10,0) ; THE ROUTINE PARSES THE MESSAGE AND DETERMINES IF THERE IS A QUERY "RTN","VAFHQRY",11,0) ; SEGMENT PRESENT. IF SO, THE QUERY IS REQUESTING PATIENT DEMOGRAPHIC "RTN","VAFHQRY",12,0) ; DATA IN A PID SEGMENT "RTN","VAFHQRY",13,0) ; "RTN","VAFHQRY",14,0) N ERR1,ERR2,ERR3,COMPNENT,SSN,DFN,VAQD "RTN","VAFHQRY",15,0) S ERR1="Invalid or missing access code" "RTN","VAFHQRY",16,0) S ERR2="Missing QRD Segment" "RTN","VAFHQRY",17,0) S ERR3="Could not resolve DFN" "RTN","VAFHQRY",18,0) ;I $G(HLDUZ)'>0 S HLERR=ERR1 G ACK ;Invalid or missing access code "RTN","VAFHQRY",19,0) S HLQ=HL("Q"),HLFS=HL("FS"),HLECH=HL("ECH") "RTN","VAFHQRY",20,0) ; "RTN","VAFHQRY",21,0) S COMPNENT=$E(HL("ECH")) ;hlech "RTN","VAFHQRY",22,0) K VADC,HLERR "RTN","VAFHQRY",23,0) ;D INITIZE^VAFHUTL9(HLDA) ;QUERY MESSAGE RETURNED IN VADC() ARRAY "RTN","VAFHQRY",24,0) D INIT1 "RTN","VAFHQRY",25,0) S VAQD=$$SEG1^VAFHUTL9("QRD",1,"QRD") "RTN","VAFHQRY",26,0) I VAQD="" S HLERR=ERR2 G ACK ;Missing QRD segment "RTN","VAFHQRY",27,0) ; "RTN","VAFHQRY",28,0) PARSE ; "RTN","VAFHQRY",29,0) S SSN=$P(VAQD,HLFS,9) "RTN","VAFHQRY",30,0) S DFN=$$SSNDFN^VAFHUTL9(SSN) "RTN","VAFHQRY",31,0) I DFN'>0 S HLERR=ERR3 G ACK "RTN","VAFHQRY",32,0) ; "RTN","VAFHQRY",33,0) S HLA("HLS",1)="MSA"_HL("FS")_$S(HL:$S(HL("VER")=2.1:"AR",1:"CR"),1:"CA")_HL("FS")_HL("MID")_HL("FS")_$P(HL,"^",2) "RTN","VAFHQRY",34,0) S HLA("HLS",2)=VAQD "RTN","VAFHQRY",35,0) ; "RTN","VAFHQRY",36,0) S HLA("HLS",3)=$$EN^VAFHLPID(DFN,",2,3,4,5,6,7,8,9,10B,11,12,13,14,15,16,17,18,19,22B") "RTN","VAFHQRY",37,0) ; "RTN","VAFHQRY",38,0) ACK I $D(HLERR) S HLA("HLS",2)="MSA"_HLFS_"AE"_HLFS_HLMID_HLFS_HLERR G EXIT "RTN","VAFHQRY",39,0) ; "RTN","VAFHQRY",40,0) EXIT S HLDT=$$NOW^XLFDT() "RTN","VAFHQRY",41,0) D GENERATE^HLMA("VAFH A19","LM",1,.HLRESLT,"",.HL) "RTN","VAFHQRY",42,0) Q "RTN","VAFHQRY",43,0) ; "RTN","VAFHQRY",44,0) INIT1 F I=1:1 X HLNEXT Q:HLQUIT'>0 S X(I)=HLNODE MERGE X(I)=HLNODE "RTN","VAFHQRY",45,0) MERGE VADC=X "RTN","VAFHQRY",46,0) Q "SEC","^DIC",10.2,10.2,0,"AUDIT") "SEC","^DIC",10.2,10.2,0,"DD") @ "SEC","^DIC",10.2,10.2,0,"DEL") @ "SEC","^DIC",10.2,10.2,0,"LAYGO") @ "SEC","^DIC",10.2,10.2,0,"RD") d "SEC","^DIC",10.2,10.2,0,"WR") @ "SEC","^DIC",10.3,10.3,0,"AUDIT") "SEC","^DIC",10.3,10.3,0,"DD") @ "SEC","^DIC",10.3,10.3,0,"DEL") @ "SEC","^DIC",10.3,10.3,0,"LAYGO") @ "SEC","^DIC",10.3,10.3,0,"RD") d "SEC","^DIC",10.3,10.3,0,"WR") @ "UP",2,2.02,-1) 2^.02 "UP",2,2.02,0) 2.02 "UP",2,2.06,-1) 2^.06 "UP",2,2.06,0) 2.06 "VER") 8.0^22.0 "^DD",2,2,.06,0) RACE^P10'I^DIC(10,^0;6^Q "^DD",2,2,.06,1,0) ^.1 "^DD",2,2,.06,1,991,0) 2^AVAFC06^MUMPS "^DD",2,2,.06,1,991,1) D:($T(AVAFC^VAFCDD01)'="") AVAFC^VAFCDD01(DA) "^DD",2,2,.06,1,991,2) D:($T(AVAFC^VAFCDD01)'="") AVAFC^VAFCDD01(DA) "^DD",2,2,.06,1,991,"%D",0) ^^11^11^2990920^^ "^DD",2,2,.06,1,991,"%D",1,0) This cross reference is used to remember that changes were made to the "^DD",2,2,.06,1,991,"%D",2,0) PATIENT file (#2) outside of the Registration process. Execution of this "^DD",2,2,.06,1,991,"%D",3,0) cross reference will create an entry in the ADT/HL7 PIVOT file (#391.71) "^DD",2,2,.06,1,991,"%D",4,0) and mark it as requiring transmission of an HL7 ADT-A08 message. "^DD",2,2,.06,1,991,"%D",5,0) "^DD",2,2,.06,1,991,"%D",6,0) The local variable VAFCFLG will be set to 1 if the cross reference is "^DD",2,2,.06,1,991,"%D",7,0) not executed because the change is being made from within the Registration "^DD",2,2,.06,1,991,"%D",8,0) process. "^DD",2,2,.06,1,991,"%D",9,0) "^DD",2,2,.06,1,991,"%D",10,0) Execution of this cross reference can be prevented by setting the local "^DD",2,2,.06,1,991,"%D",11,0) variable VAFCA08 equal to 1. "^DD",2,2,.06,1,991,"DT") 2970609 "^DD",2,2,.06,1,992,0) 2^ADGRU06^MUMPS "^DD",2,2,.06,1,992,1) D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) "^DD",2,2,.06,1,992,2) D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) "^DD",2,2,.06,1,992,"%D",0) ^^9^9^2990920^ "^DD",2,2,.06,1,992,"%D",1,0) This cross reference is used to remember that changes were made to a "^DD",2,2,.06,1,992,"%D",2,0) monitored data field in the PATIENT File (#2) required for a vendor "^DD",2,2,.06,1,992,"%D",3,0) RAI/MDS COTS system. Execution of this cross reference will create "^DD",2,2,.06,1,992,"%D",4,0) an entry in the ADT/HL7 PIVOT file (#391.71) and mark it as requiring "^DD",2,2,.06,1,992,"%D",5,0) transmission of an HL7 demographic A08 update message to the COTS "^DD",2,2,.06,1,992,"%D",6,0) interface. "^DD",2,2,.06,1,992,"%D",7,0) "^DD",2,2,.06,1,992,"%D",8,0) The local variable DGRUGA08 will be set to 1 if the cross reference is "^DD",2,2,.06,1,992,"%D",9,0) not to be executed as part of a re-indexing. "^DD",2,2,.06,1,992,"DT") 2990920 "^DD",2,2,.06,3) Select from the available listing the race which best identifies this patient. "^DD",2,2,.06,20,0) ^.3LA^1^1 "^DD",2,2,.06,20,1,0) DEMOG^ "^DD",2,2,.06,21,0) ^^2^2^3020726^ "^DD",2,2,.06,21,1,0) This field is no longer being populated and the values that are on file "^DD",2,2,.06,21,2,0) were collected prior to installation of patch DG*5.3*415. "^DD",2,2,.06,"DT") 3020711 "^DD",2,2,2,0) RACE INFORMATION^2.02P^^.02;0 "^DD",2,2,6,0) ETHNICITY INFORMATION^2.06PA^^.06;0 "^DD",2,2.02,0) RACE INFORMATION SUB-FIELD^^.02^2 "^DD",2,2.02,0,"DT") 3020814 "^DD",2,2.02,0,"IX","B",2.02,.01) "^DD",2,2.02,0,"NM","RACE INFORMATION") "^DD",2,2.02,0,"UP") 2 "^DD",2,2.02,.01,0) RACE INFORMATION^M*P10'X^DIC(10,^0;1^S DIC("S")="I '$G(^(.02))" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X S:$D(X) DINUM=X "^DD",2,2.02,.01,1,0) ^.1 "^DD",2,2.02,.01,1,1,0) 2.02^B "^DD",2,2.02,.01,1,1,1) S ^DPT(DA(1),.02,"B",$E(X,1,30),DA)="" "^DD",2,2.02,.01,1,1,2) K ^DPT(DA(1),.02,"B",$E(X,1,30),DA) "^DD",2,2.02,.01,1,2,0) ^^TRIGGER^2.02^.02 "^DD",2,2.02,.01,1,2,1) X ^DD(2.02,.01,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.02,D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=+$O(^DIC(10.3,"C","S",0)) S:X=0 X="" X ^DD(2.02,.01,1,2,1.4) "^DD",2,2.02,.01,1,2,1.3) K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S Y(1)=$S($D(^DPT(D0,.02,D1,0)):^(0),1:"") S X=$S('$D(^DIC(10.3,+$P(Y(1),U,2),0)):"",1:$P(^(0),U,1))="" "^DD",2,2.02,.01,1,2,1.4) S DIH=$G(^DPT(DIV(0),.02,DIV(1),0)),DIV=X S $P(^(0),U,2)=DIV,DIH=2.02,DIG=.02 D ^DICR "^DD",2,2.02,.01,1,2,2) Q "^DD",2,2.02,.01,1,2,"%D",0) ^.101^1^1^3020709^^ "^DD",2,2.02,.01,1,2,"%D",1,0) SELF IDENTIFICATION is the default value for collection method "^DD",2,2.02,.01,1,2,"CREATE CONDITION") METHOD OF COLLECTION="" "^DD",2,2.02,.01,1,2,"CREATE VALUE") S X=+$O(^DIC(10.3,"C","S",0)) S:X=0 X="" "^DD",2,2.02,.01,1,2,"DELETE VALUE") NO EFFECT "^DD",2,2.02,.01,1,2,"DT") 3020709 "^DD",2,2.02,.01,1,2,"FIELD") METHOD "^DD",2,2.02,.01,3) Select from the available listing all races which best identify this patient "^DD",2,2.02,.01,12) Inactive values are not selectable "^DD",2,2.02,.01,12.1) S DIC("S")="I '$G(^(.02))" "^DD",2,2.02,.01,21,0) ^^1^1^3020726^ "^DD",2,2.02,.01,21,1,0) Patient's race "^DD",2,2.02,.01,"DT") 3020709 "^DD",2,2.02,.02,0) METHOD OF COLLECTION^RP10.3'^DIC(10.3,^0;2^Q "^DD",2,2.02,.02,3) Enter the method in which the race value was collected "^DD",2,2.02,.02,5,1,0) 2.02^.01^2 "^DD",2,2.02,.02,21,0) ^.001^1^1^3020814^^ "^DD",2,2.02,.02,21,1,0) Method used to collect patient's race "^DD",2,2.02,.02,"DT") 3020814 "^DD",2,2.06,0) ETHNICITY INFORMATION SUB-FIELD^^.02^2 "^DD",2,2.06,0,"DT") 3020814 "^DD",2,2.06,0,"IX","B",2.06,.01) "^DD",2,2.06,0,"NM","ETHNICITY INFORMATION") "^DD",2,2.06,0,"UP") 2 "^DD",2,2.06,.01,0) ETHNICITY INFORMATION^*P10.2'X^DIC(10.2,^0;1^S DIC("S")="I '$G(^(.02))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X S:$D(X) DINUM=X "^DD",2,2.06,.01,1,0) ^.1^^-1 "^DD",2,2.06,.01,1,1,0) 2.06^B "^DD",2,2.06,.01,1,1,1) S ^DPT(DA(1),.06,"B",$E(X,1,30),DA)="" "^DD",2,2.06,.01,1,1,2) K ^DPT(DA(1),.06,"B",$E(X,1,30),DA) "^DD",2,2.06,.01,1,2,0) ^^TRIGGER^2.06^.02 "^DD",2,2.06,.01,1,2,1) X ^DD(2.06,.01,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.06,D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=+$O(^DIC(10.3,"C","S",0)) S:X=0 X="" X ^DD(2.06,.01,1,2,1.4) "^DD",2,2.06,.01,1,2,1.3) K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S Y(1)=$S($D(^DPT(D0,.06,D1,0)):^(0),1:"") S X=$S('$D(^DIC(10.3,+$P(Y(1),U,2),0)):"",1:$P(^(0),U,1))="" "^DD",2,2.06,.01,1,2,1.4) S DIH=$G(^DPT(DIV(0),.06,DIV(1),0)),DIV=X S $P(^(0),U,2)=DIV,DIH=2.06,DIG=.02 D ^DICR "^DD",2,2.06,.01,1,2,2) Q "^DD",2,2.06,.01,1,2,"%D",0) ^^1^1^3020709^ "^DD",2,2.06,.01,1,2,"%D",1,0) SELF IDENTIFICATION is the default value for collection method "^DD",2,2.06,.01,1,2,"CREATE CONDITION") METHOD OF COLLECTION="" "^DD",2,2.06,.01,1,2,"CREATE VALUE") S X=+$O(^DIC(10.3,"C","S",0)) S:X=0 X="" "^DD",2,2.06,.01,1,2,"DELETE VALUE") NO EFFECT "^DD",2,2.06,.01,1,2,"DT") 3020709 "^DD",2,2.06,.01,1,2,"FIELD") METHOD "^DD",2,2.06,.01,3) Select from the available listing the ethnicity which best identifies this patient "^DD",2,2.06,.01,12) Inactive values are not selectable "^DD",2,2.06,.01,12.1) S DIC("S")="I '$G(^(.02))" "^DD",2,2.06,.01,21,0) ^^1^1^3020726^ "^DD",2,2.06,.01,21,1,0) Patient's ethnicity "^DD",2,2.06,.01,23,0) ^.001^4^4^3020726^^^ "^DD",2,2.06,.01,23,1,0) Although this field is defined to be multi-valued, the AONLYONE cross "^DD",2,2.06,.01,23,2,0) reference prevents multiple values from being stored. This is because "^DD",2,2.06,.01,23,3,0) the current business definition for ethnicity only accounts for a single "^DD",2,2.06,.01,23,4,0) value. "^DD",2,2.06,.01,"DT") 3020712 "^DD",2,2.06,.02,0) METHOD OF COLLECTION^RP10.3'^DIC(10.3,^0;2^Q "^DD",2,2.06,.02,3) Enter the method in which the ethnicity value was collected "^DD",2,2.06,.02,5,1,0) 2.06^.01^2 "^DD",2,2.06,.02,21,0) ^.001^1^1^3020814^^ "^DD",2,2.06,.02,21,1,0) Method used to collect patient's ethnicity "^DD",2,2.06,.02,"DT") 3020814 "^DD",10,10,0) FIELD^NL^202^8 "^DD",10,10,0,"DDA") N "^DD",10,10,0,"DT") 3020801 "^DD",10,10,0,"ID",2) N TMP S TMP=$P($G(^(0)),"^",2) I TMP'="" D EN^DDIOL(TMP,,"?$X+2") "^DD",10,10,0,"ID",200) I +$G(^(.02)) D EN^DDIOL("** INACTIVE **",,"?$X+2") "^DD",10,10,0,"IX","AHL7",10,3) "^DD",10,10,0,"IX","B",10,.01) "^DD",10,10,0,"IX","C",10,2) "^DD",10,10,0,"NM","RACE") "^DD",10,10,0,"PT",2,.06) "^DD",10,10,0,"PT",2.02,.01) "^DD",10,10,0,"PT",67,.06) "^DD",10,10,0,"PT",910,.09) "^DD",10,10,0,"PT",912.04,.04) "^DD",10,10,0,"PT",912.05,.04) "^DD",10,10,0,"VRPK") DG "^DD",10,10,.01,0) NAME^RF^^0;1^K:$L(X)>45!($L(X)<4) X "^DD",10,10,.01,1,0) ^.1 "^DD",10,10,.01,1,1,0) 10^B "^DD",10,10,.01,1,1,1) S ^DIC(10,"B",$E(X,1,30),DA)="" "^DD",10,10,.01,1,1,2) K ^DIC(10,"B",$E(X,1,30),DA) "^DD",10,10,.01,3) Enter the race name, 4-45 characters. "^DD",10,10,.01,21,0) ^.001^6^6^3020801^^^^ "^DD",10,10,.01,21,1,0) This field contains the name of a race as selectable during enter/edit of "^DD",10,10,.01,21,2,0) patient data information. "^DD",10,10,.01,21,3,0) "^DD",10,10,.01,21,4,0) These entries are distributed by the MAS module and entry or edit of any "^DD",10,10,.01,21,5,0) data elements contained in this file could have negative impacts on the "^DD",10,10,.01,21,6,0) performance of the MAS or other DHCP modules. "^DD",10,10,.01,"DT") 3020801 "^DD",10,10,2,0) ABBREVIATION^F^^0;2^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>5!($L(X)<1) X "^DD",10,10,2,1,0) ^.1 "^DD",10,10,2,1,1,0) 10^C "^DD",10,10,2,1,1,1) S ^DIC(10,"C",$E(X,1,30),DA)="" "^DD",10,10,2,1,1,2) K ^DIC(10,"C",$E(X,1,30),DA) "^DD",10,10,2,3) ANSWER MUST BE 1-5 CHARACTERS IN LENGTH "^DD",10,10,2,21,0) ^^3^3^2930127^^^ "^DD",10,10,2,21,1,0) This field contains the abbreviation for this race entry. This may appear "^DD",10,10,2,21,2,0) on various outputs where there is insufficient room to print the entire "^DD",10,10,2,21,3,0) name of the race. "^DD",10,10,2,"DT") 2840820 "^DD",10,10,3,0) HL7 VALUE^RF^^0;3^K:$L(X)>10!($L(X)<1) X "^DD",10,10,3,1,0) ^.1 "^DD",10,10,3,1,1,0) 10^AHL7 "^DD",10,10,3,1,1,1) S ^DIC(10,"AHL7",$E(X,1,30),DA)="" "^DD",10,10,3,1,1,2) K ^DIC(10,"AHL7",$E(X,1,30),DA) "^DD",10,10,3,1,1,"%D",0) ^^1^1^3020814^ "^DD",10,10,3,1,1,"%D",1,0) Regular cross reference on the HL7 value "^DD",10,10,3,1,1,"DT") 3020814 "^DD",10,10,3,3) Answer must be 1-10 characters in length. "^DD",10,10,3,21,0) ^^1^1^3020624^ "^DD",10,10,3,21,1,0) The HL7 representation of this race "^DD",10,10,3,"DT") 3020814 "^DD",10,10,4,0) CDC VALUE^F^^0;4^K:$L(X)>6!($L(X)<6)!'(X?4N1"-"1N) X "^DD",10,10,4,3) Answer must be in the format NNNN-N "^DD",10,10,4,21,0) ^^1^1^3020624^ "^DD",10,10,4,21,1,0) The CDC representation of this race "^DD",10,10,4,"DT") 3020624 "^DD",10,10,5,0) PTF VALUE^RF^^0;5^K:$L(X)>1!($L(X)<1) X "^DD",10,10,5,3) Answer must be 1 character in length. "^DD",10,10,5,21,0) ^^1^1^3020624^ "^DD",10,10,5,21,1,0) The PTF represenation of this race "^DD",10,10,5,"DT") 3020624 "^DD",10,10,100,0) SYNONYM^10.01^^.01;0 "^DD",10,10,100,21,0) ^^2^2^2911222^ "^DD",10,10,100,21,1,0) This multiple contains all alternate names by which this race can be called "^DD",10,10,100,21,2,0) up by a user. "^DD",10,10,200,0) INACTIVE^S^1:YES;^.02;1^Q "^DD",10,10,200,1,0) ^.1^^0 "^DD",10,10,200,21,0) ^^1^1^3020624^ "^DD",10,10,200,21,1,0) This field is used to denote that this race value is no longer active. "^DD",10,10,200,"DT") 3020624 "^DD",10,10,202,0) INACTIVATION DATE^D^^.02;2^S %DT="EX" D ^%DT S X=Y K:X<1 X "^DD",10,10,202,3) (No range limit on date) "^DD",10,10,202,21,0) ^^1^1^3020624^ "^DD",10,10,202,21,1,0) Date that this race became inactive "^DD",10,10,202,"DT") 3020624 "^DD",10,10.01,0) SYNONYM SUB-FIELD^NL^.01^1 "^DD",10,10.01,0,"NM","SYNONYM") "^DD",10,10.01,0,"UP") 10 "^DD",10,10.01,.01,0) SYNONYM^F^^0;1^K:$L(X)>16!($L(X)<1) X "^DD",10,10.01,.01,3) ANSWER MUST BE 1-16 CHARACTERS IN LENGTH "^DD",10,10.01,.01,21,0) ^^3^3^2911222^ "^DD",10,10.01,.01,21,1,0) This field contains another name by which this race can be called up. When "^DD",10,10.01,.01,21,2,0) entering this race, users will be allowed to select either the name of the "^DD",10,10.01,.01,21,3,0) race or one of the synonyms. "^DD",10.2,10.2,0) FIELD^^202^8 "^DD",10.2,10.2,0,"DDA") N "^DD",10.2,10.2,0,"DT") 3020624 "^DD",10.2,10.2,0,"ID",2) N TMP S TMP=$P($G(^(0)),"^",2) I TMP'="" D EN^DDIOL(TMP,,"?$X+2") "^DD",10.2,10.2,0,"ID",200) I +$G(^(.02)) D EN^DDIOL("** INACTIVE **",,"?$X+2") "^DD",10.2,10.2,0,"IX","AHL7",10.2,3) "^DD",10.2,10.2,0,"IX","B",10.2,.01) "^DD",10.2,10.2,0,"IX","C",10.2,2) "^DD",10.2,10.2,0,"NM","ETHNICITY") "^DD",10.2,10.2,0,"PT",2.06,.01) "^DD",10.2,10.2,0,"VRPK") DG "^DD",10.2,10.2,.01,0) NAME^RF^^0;1^K:$L(X)>30!($L(X)<3)!'(X'?1P.E) X "^DD",10.2,10.2,.01,1,0) ^.1 "^DD",10.2,10.2,.01,1,1,0) 10.2^B "^DD",10.2,10.2,.01,1,1,1) S ^DIC(10.2,"B",$E(X,1,30),DA)="" "^DD",10.2,10.2,.01,1,1,2) K ^DIC(10.2,"B",$E(X,1,30),DA) "^DD",10.2,10.2,.01,3) Answer must be 3-30 characters in length "^DD",10.2,10.2,.01,21,0) ^^5^5^3020624^ "^DD",10.2,10.2,.01,21,1,0) This field contains the name of an ethnicity as selectable during "^DD",10.2,10.2,.01,21,2,0) enter/edit of patient data information. "^DD",10.2,10.2,.01,21,3,0) "^DD",10.2,10.2,.01,21,4,0) These entries are maintained by VA Central Office and entry/edit of "^DD",10.2,10.2,.01,21,5,0) entries is not allowed. "^DD",10.2,10.2,.01,"DT") 3020624 "^DD",10.2,10.2,2,0) ABBREVIATION^F^^0;2^K:$L(X)>5!($L(X)<1) X "^DD",10.2,10.2,2,1,0) ^.1 "^DD",10.2,10.2,2,1,1,0) 10.2^C "^DD",10.2,10.2,2,1,1,1) S ^DIC(10.2,"C",$E(X,1,30),DA)="" "^DD",10.2,10.2,2,1,1,2) K ^DIC(10.2,"C",$E(X,1,30),DA) "^DD",10.2,10.2,2,1,1,"DT") 3020624 "^DD",10.2,10.2,2,3) Answer must be 1-5 characters in length "^DD",10.2,10.2,2,21,0) ^^3^3^3020624^ "^DD",10.2,10.2,2,21,1,0) This field contains the abbreviation for this ethnicity entry. This may "^DD",10.2,10.2,2,21,2,0) appear on various outputs where there is insufficient room to print the "^DD",10.2,10.2,2,21,3,0) entire name of the ethnicity. "^DD",10.2,10.2,2,"DT") 3020624 "^DD",10.2,10.2,3,0) HL7 VALUE^RF^^0;3^K:$L(X)>10!($L(X)<1) X "^DD",10.2,10.2,3,1,0) ^.1 "^DD",10.2,10.2,3,1,1,0) 10.2^AHL7 "^DD",10.2,10.2,3,1,1,1) S ^DIC(10.2,"AHL7",$E(X,1,30),DA)="" "^DD",10.2,10.2,3,1,1,2) K ^DIC(10.2,"AHL7",$E(X,1,30),DA) "^DD",10.2,10.2,3,1,1,"%D",0) ^^1^1^3020814^ "^DD",10.2,10.2,3,1,1,"%D",1,0) Regular cross reference on the HL7 value "^DD",10.2,10.2,3,1,1,"DT") 3020814 "^DD",10.2,10.2,3,3) Answer must be 1-10 characters in length "^DD",10.2,10.2,3,21,0) ^.001^1^1^3020624^^ "^DD",10.2,10.2,3,21,1,0) The HL7 representation of this ethnicity "^DD",10.2,10.2,3,"DT") 3020814 "^DD",10.2,10.2,4,0) CDC VALUE^F^^0;4^K:$L(X)>6!($L(X)<6)!'(X?4N1"-"1N) X "^DD",10.2,10.2,4,3) Answer must be in the format NNNN-N "^DD",10.2,10.2,4,21,0) ^^1^1^3020624^ "^DD",10.2,10.2,4,21,1,0) CDC representation of this ethnicity "^DD",10.2,10.2,4,"DT") 3020624 "^DD",10.2,10.2,5,0) PTF VALUE^RF^^0;5^K:$L(X)>1!($L(X)<1) X "^DD",10.2,10.2,5,3) Answer must be 1 character in length. "^DD",10.2,10.2,5,21,0) ^.001^1^1^3020624^^ "^DD",10.2,10.2,5,21,1,0) PTF representation of this ethnicity "^DD",10.2,10.2,5,"DT") 3020624 "^DD",10.2,10.2,100,0) SYNONYM^10.21^^.01;0 "^DD",10.2,10.2,200,0) INACTIVE^S^1:YES;^.02;1^Q "^DD",10.2,10.2,200,1,0) ^.1^^0 "^DD",10.2,10.2,200,21,0) ^^2^2^3020624^ "^DD",10.2,10.2,200,21,1,0) This field is used to denote that this ethnicity value is no longer "^DD",10.2,10.2,200,21,2,0) active. "^DD",10.2,10.2,200,"DT") 3020624 "^DD",10.2,10.2,202,0) INACTIVATION DATE^D^^.02;2^S %DT="EX" D ^%DT S X=Y K:X<1 X "^DD",10.2,10.2,202,3) (No range limit on date) "^DD",10.2,10.2,202,21,0) ^^1^1^3020624^ "^DD",10.2,10.2,202,21,1,0) Date that this ethnicity became inactive "^DD",10.2,10.2,202,"DT") 3020624 "^DD",10.2,10.21,0) SYNONYM SUB-FIELD^^.01^1 "^DD",10.2,10.21,0,"DT") 3020624 "^DD",10.2,10.21,0,"IX","B",10.21,.01) "^DD",10.2,10.21,0,"NM","SYNONYM") "^DD",10.2,10.21,0,"UP") 10.2 "^DD",10.2,10.21,.01,0) SYNONYM^F^^0;1^K:$L(X)>16!($L(X)<1) X "^DD",10.2,10.21,.01,1,0) ^.1 "^DD",10.2,10.21,.01,1,1,0) 10.21^B "^DD",10.2,10.21,.01,1,1,1) S ^DIC(10.2,DA(1),.01,"B",$E(X,1,30),DA)="" "^DD",10.2,10.21,.01,1,1,2) K ^DIC(10.2,DA(1),.01,"B",$E(X,1,30),DA) "^DD",10.2,10.21,.01,3) Answer must be 1-16 characters in length. "^DD",10.2,10.21,.01,21,0) ^.001^3^3^3020624^^ "^DD",10.2,10.21,.01,21,1,0) This field contains another name by which this ethnicity can be called "^DD",10.2,10.21,.01,21,2,0) up. When entering this ethnicity, users will be allowed to select either "^DD",10.2,10.21,.01,21,3,0) the name of the ethnicity or one of the synonyms. "^DD",10.2,10.21,.01,"DT") 3020624 "^DD",10.3,10.3,0) FIELD^^.05^4 "^DD",10.3,10.3,0,"DDA") N "^DD",10.3,10.3,0,"DT") 3020717 "^DD",10.3,10.3,0,"ID",.02) N TMP S TMP=$P($G(^(0)),"^",2) I TMP'="" D EN^DDIOL(TMP,,"?$X+2") "^DD",10.3,10.3,0,"IX","AHL7",10.3,.03) "^DD",10.3,10.3,0,"IX","B",10.3,.01) "^DD",10.3,10.3,0,"IX","C",10.3,.02) "^DD",10.3,10.3,0,"NM","RACE AND ETHNICITY COLLECTION METHOD") "^DD",10.3,10.3,0,"PT",2.02,.02) "^DD",10.3,10.3,0,"PT",2.06,.02) "^DD",10.3,10.3,0,"VRPK") DG "^DD",10.3,10.3,.01,0) NAME^RF^^0;1^K:$L(X)>30!($L(X)<3)!'(X'?1P.E) X "^DD",10.3,10.3,.01,1,0) ^.1 "^DD",10.3,10.3,.01,1,1,0) 10.3^B "^DD",10.3,10.3,.01,1,1,1) S ^DIC(10.3,"B",$E(X,1,30),DA)="" "^DD",10.3,10.3,.01,1,1,2) K ^DIC(10.3,"B",$E(X,1,30),DA) "^DD",10.3,10.3,.01,3) Answer must be 3-30 characters in length "^DD",10.3,10.3,.01,21,0) ^^5^5^3020624^ "^DD",10.3,10.3,.01,21,1,0) This field contains the name of a collection method used to obtain a value "^DD",10.3,10.3,.01,21,2,0) for race and ethnicity during enter/edit of patient data information. "^DD",10.3,10.3,.01,21,3,0) "^DD",10.3,10.3,.01,21,4,0) These entries are maintained by VA Central Office and entry/edit of "^DD",10.3,10.3,.01,21,5,0) entries is not allowed. "^DD",10.3,10.3,.01,"DT") 3020624 "^DD",10.3,10.3,.02,0) ABBREVIATION^F^^0;2^K:$L(X)>5!($L(X)<1) X "^DD",10.3,10.3,.02,1,0) ^.1 "^DD",10.3,10.3,.02,1,1,0) 10.3^C "^DD",10.3,10.3,.02,1,1,1) S ^DIC(10.3,"C",$E(X,1,30),DA)="" "^DD",10.3,10.3,.02,1,1,2) K ^DIC(10.3,"C",$E(X,1,30),DA) "^DD",10.3,10.3,.02,1,1,"DT") 3020625 "^DD",10.3,10.3,.02,3) Answer must be 1-5 characters in length "^DD",10.3,10.3,.02,21,0) ^^3^3^3020624^ "^DD",10.3,10.3,.02,21,1,0) This field contains the abbreviation for this collection method entry. "^DD",10.3,10.3,.02,21,2,0) This may appear on various outputs where there is insufficient room to "^DD",10.3,10.3,.02,21,3,0) print the entire name of the collection method. "^DD",10.3,10.3,.02,"DT") 3020625 "^DD",10.3,10.3,.03,0) HL7 VALUE^RF^^0;3^K:$L(X)>3!($L(X)<1) X "^DD",10.3,10.3,.03,1,0) ^.1 "^DD",10.3,10.3,.03,1,1,0) 10.3^AHL7 "^DD",10.3,10.3,.03,1,1,1) S ^DIC(10.3,"AHL7",$E(X,1,30),DA)="" "^DD",10.3,10.3,.03,1,1,2) K ^DIC(10.3,"AHL7",$E(X,1,30),DA) "^DD",10.3,10.3,.03,1,1,"%D",0) ^^1^1^3020814^ "^DD",10.3,10.3,.03,1,1,"%D",1,0) Regular cross reference on the HL7 value "^DD",10.3,10.3,.03,1,1,"DT") 3020814 "^DD",10.3,10.3,.03,3) Answer must be 1-3 characters in length. "^DD",10.3,10.3,.03,21,0) ^^1^1^3020624^ "^DD",10.3,10.3,.03,21,1,0) HL7 representation of this collection method "^DD",10.3,10.3,.03,"DT") 3020814 "^DD",10.3,10.3,.05,0) PTF VALUE^RF^^0;5^K:$L(X)>1!($L(X)<1) X "^DD",10.3,10.3,.05,3) Answer must be 1 character in length. "^DD",10.3,10.3,.05,21,0) ^^1^1^3020717^ "^DD",10.3,10.3,.05,21,1,0) PTF representation of this collection method "^DD",10.3,10.3,.05,"DT") 3020717 "^DD",45.64,45.64,0) FIELD^^.03^3 "^DD",45.64,45.64,0,"DT") 2921208 "^DD",45.64,45.64,0,"IX","B",45.64,.01) "^DD",45.64,45.64,0,"NM","PTF AUSTIN ERROR CODES") "^DD",45.64,45.64,.01,0) CODE^RF^^0;1^K:$L(X)>30!($L(X)<3)!'(X'?1P.E) X "^DD",45.64,45.64,.01,.1) ERROR CODE "^DD",45.64,45.64,.01,1,0) ^.1 "^DD",45.64,45.64,.01,1,1,0) 45.64^B "^DD",45.64,45.64,.01,1,1,1) S ^DGP(45.64,"B",$E(X,1,30),DA)="" "^DD",45.64,45.64,.01,1,1,2) K ^DGP(45.64,"B",$E(X,1,30),DA) "^DD",45.64,45.64,.01,3) Answer must be 3-30 characters in length. "^DD",45.64,45.64,.01,21,0) ^^2^2^2921208^ "^DD",45.64,45.64,.01,21,1,0) This field contains the PTF Austin Error Codes. Each code begins with "^DD",45.64,45.64,.01,21,2,0) a digit cooresponding to the record that the error occured in. "^DD",45.64,45.64,.01,"DT") 2921208 "^DD",45.64,45.64,.02,0) DESCRIPTION^F^^0;2^K:$L(X)>70!($L(X)<3) X "^DD",45.64,45.64,.02,3) Answer must be 3-70 characters in length. "^DD",45.64,45.64,.02,"DT") 2921208 "^DD",45.64,45.64,.03,0) POSITION^NJ2,0^^0;3^K:+X'=X!(X>30)!(X<1)!(X?.E1"."1N.N) X "^DD",45.64,45.64,.03,3) Type a Number between 1 and 30, 0 Decimal Digits "^DD",45.64,45.64,.03,"DT") 2921208 "^DIC",10,10,0) RACE^10I "^DIC",10,10,0,"GL") ^DIC(10, "^DIC",10,10,"%",0) ^1.005^1^1 "^DIC",10,10,"%",1,0) VA "^DIC",10,10,"%","B","VA",1) "^DIC",10,10,"%D",0) ^^3^3^3020624^ "^DIC",10,10,"%D",1,0) This file contains the list of valid races. The allowable entries are "^DIC",10,10,"%D",2,0) maintained by VA Central Office and, as such, alteration and/or addition "^DIC",10,10,"%D",3,0) of entries is not allowed. "^DIC",10,"B","RACE",10) "^DIC",10.2,10.2,0) ETHNICITY^10.2I "^DIC",10.2,10.2,0,"GL") ^DIC(10.2, "^DIC",10.2,10.2,"%",0) ^1.005^1^1 "^DIC",10.2,10.2,"%",1,0) VA "^DIC",10.2,10.2,"%","B","VA",1) "^DIC",10.2,10.2,"%D",0) ^^3^3^3020624^ "^DIC",10.2,10.2,"%D",1,0) This file contains the list of valid ethnicities. The allowable entries "^DIC",10.2,10.2,"%D",2,0) are maintained by VA Central Office and, as such, alteration and/or "^DIC",10.2,10.2,"%D",3,0) addition of entries is not allowed. "^DIC",10.2,"B","ETHNICITY",10.2) "^DIC",10.3,10.3,0) RACE AND ETHNICITY COLLECTION METHOD^10.3I "^DIC",10.3,10.3,0,"GL") ^DIC(10.3, "^DIC",10.3,10.3,"%",0) ^1.005^1^1 "^DIC",10.3,10.3,"%",1,0) VA "^DIC",10.3,10.3,"%","B","VA",1) "^DIC",10.3,10.3,"%D",0) ^^3^3^3020624^ "^DIC",10.3,10.3,"%D",1,0) This file contains the list of valid collection methods for race and "^DIC",10.3,10.3,"%D",2,0) ethnicity. The allowable entries are maintained by VA Central Office and, "^DIC",10.3,10.3,"%D",3,0) as such, alteration and/or addition of entries is not allowed. "^DIC",10.3,"B","RACE AND ETHNICITY COLLECTION METHOD",10.3) "^DIC",45.64,45.64,0) PTF AUSTIN ERROR CODES^45.64 "^DIC",45.64,45.64,0,"GL") ^DGP(45.64, "^DIC",45.64,"B","PTF AUSTIN ERROR CODES",45.64) **INSTALL NAME** SD*5.3*254 "BLD",3614,0) SD*5.3*254^SCHEDULING^0^3030102^y "BLD",3614,4,0) ^9.64PA^409.76^2 "BLD",3614,4,409.76,0) 409.76 "BLD",3614,4,409.76,222) n^n^f^^n^^y^o^n "BLD",3614,4,409.76,224) N TMP S TMP=$P(^(0),"^",1) I (TMP=238)!(TMP=2380) "BLD",3614,4,409.92,0) 409.92 "BLD",3614,4,409.92,222) n^n^f^^n^^y^o^n "BLD",3614,4,409.92,224) N TMP S TMP=$P(^(0),"^",1) I (TMP="0703")!(TMP="0706") "BLD",3614,4,"B",409.76,409.76) "BLD",3614,4,"B",409.92,409.92) "BLD",3614,"ABPKG") n "BLD",3614,"KRN",0) ^9.67PA^8989.52^19 "BLD",3614,"KRN",.4,0) .4 "BLD",3614,"KRN",.401,0) .401 "BLD",3614,"KRN",.402,0) .402 "BLD",3614,"KRN",.403,0) .403 "BLD",3614,"KRN",.5,0) .5 "BLD",3614,"KRN",.84,0) .84 "BLD",3614,"KRN",3.6,0) 3.6 "BLD",3614,"KRN",3.8,0) 3.8 "BLD",3614,"KRN",9.2,0) 9.2 "BLD",3614,"KRN",9.8,0) 9.8 "BLD",3614,"KRN",9.8,"NM",0) ^9.68A^8^8 "BLD",3614,"KRN",9.8,"NM",1,0) SDM^^0^B26612047 "BLD",3614,"KRN",9.8,"NM",2,0) SCRPW24^^0^B73184734 "BLD",3614,"KRN",9.8,"NM",3,0) SCRPW241^^0^B11894412 "BLD",3614,"KRN",9.8,"NM",4,0) SCDXMSG1^^0^B72860271 "BLD",3614,"KRN",9.8,"NM",5,0) SCMSVPID^^0^B10745780 "BLD",3614,"KRN",9.8,"NM",6,0) SCMSVUT0^^0^B44832749 "BLD",3614,"KRN",9.8,"NM",7,0) SCMSVUT2^^0^B16403958 "BLD",3614,"KRN",9.8,"NM",8,0) SCMSVUT5^^0^B2983685 "BLD",3614,"KRN",9.8,"NM","B","SCDXMSG1",4) "BLD",3614,"KRN",9.8,"NM","B","SCMSVPID",5) "BLD",3614,"KRN",9.8,"NM","B","SCMSVUT0",6) "BLD",3614,"KRN",9.8,"NM","B","SCMSVUT2",7) "BLD",3614,"KRN",9.8,"NM","B","SCMSVUT5",8) "BLD",3614,"KRN",9.8,"NM","B","SCRPW24",2) "BLD",3614,"KRN",9.8,"NM","B","SCRPW241",3) "BLD",3614,"KRN",9.8,"NM","B","SDM",1) "BLD",3614,"KRN",19,0) 19 "BLD",3614,"KRN",19.1,0) 19.1 "BLD",3614,"KRN",101,0) 101 "BLD",3614,"KRN",409.61,0) 409.61 "BLD",3614,"KRN",771,0) 771 "BLD",3614,"KRN",870,0) 870 "BLD",3614,"KRN",8989.51,0) 8989.51 "BLD",3614,"KRN",8989.52,0) 8989.52 "BLD",3614,"KRN",8994,0) 8994 "BLD",3614,"KRN","B",.4,.4) "BLD",3614,"KRN","B",.401,.401) "BLD",3614,"KRN","B",.402,.402) "BLD",3614,"KRN","B",.403,.403) "BLD",3614,"KRN","B",.5,.5) "BLD",3614,"KRN","B",.84,.84) "BLD",3614,"KRN","B",3.6,3.6) "BLD",3614,"KRN","B",3.8,3.8) "BLD",3614,"KRN","B",9.2,9.2) "BLD",3614,"KRN","B",9.8,9.8) "BLD",3614,"KRN","B",19,19) "BLD",3614,"KRN","B",19.1,19.1) "BLD",3614,"KRN","B",101,101) "BLD",3614,"KRN","B",409.61,409.61) "BLD",3614,"KRN","B",771,771) "BLD",3614,"KRN","B",870,870) "BLD",3614,"KRN","B",8989.51,8989.51) "BLD",3614,"KRN","B",8989.52,8989.52) "BLD",3614,"KRN","B",8994,8994) "BLD",3614,"QUES",0) ^9.62^^ "BLD",3614,"REQB",0) ^9.611^2^2 "BLD",3614,"REQB",1,0) SD*5.3*250^2 "BLD",3614,"REQB",2,0) SD*5.3*245^2 "BLD",3614,"REQB","B","SD*5.3*245",2) "BLD",3614,"REQB","B","SD*5.3*250",1) "DATA",409.76,274,0) 2380^V "DATA",409.76,274,1) Ethnicity code missing or invalid "DATA",409.76,274,2,0) ^409.7621^2^2^3020729^^ "DATA",409.76,274,2,1,0) Correct the patient's ethnicity code through the Patient Demographics "DATA",409.76,274,2,2,0) protocol of IEMM. "DATA",409.76,274,"CHK") S RES=$$ETHNIC^SCMSVUT2(DATA) "DATA",409.76,274,"COR") S RTN=$$DEM1^SCENIA1 "DATA",409.76,275,0) 238^N "DATA",409.76,275,1) Ethnicity code missing or invalid "DATA",409.76,275,2,0) ^^2^2^3020729^ "DATA",409.76,275,2,1,0) Correct the patient's ethnicity code through the Patient Demographics "DATA",409.76,275,2,2,0) protocol of IEMM. "DATA",409.76,275,"COR") S RTN=$$DEM1^SCENIA1 "DATA",409.92,30,0) 0703^PD^PATIENT DEMOGRAPHICS^PR^PATIENT RACE^P^^^LR^100^^^^^2^1 "DATA",409.92,30,1) PDPR "DATA",409.92,30,7) ^DIC(10, "DATA",409.92,30,8) I '$G(^(.02)) "DATA",409.92,30,11) D PDPR^SCRPW241(.SDX) "DATA",409.92,79,0) 0706^PD^PATIENT DEMOGRAPHICS^PE^PATIENT ETHNICITY^P^^^LR^100^^^^^2^1 "DATA",409.92,79,1) PDPE "DATA",409.92,79,7) ^DIC(10.2, "DATA",409.92,79,8) I '$G(^(.02)) "DATA",409.92,79,11) D PDPE^SCRPW241(.SDX) "FIA",409.76) TRANSMITTED OUTPATIENT ENCOUNTER ERROR CODE "FIA",409.76,0) ^SD(409.76, "FIA",409.76,0,0) 409.76I "FIA",409.76,0,1) n^n^f^^n^^y^o^n "FIA",409.76,0,10) "FIA",409.76,0,11) N TMP S TMP=$P(^(0),"^",1) I (TMP=238)!(TMP=2380) "FIA",409.76,0,"RLRO") "FIA",409.76,0,"VR") 5.3^SD "FIA",409.76,409.76) 0 "FIA",409.76,409.7621) 0 "FIA",409.92) ACRP REPORT TEMPLATE PARAMETER "FIA",409.92,0) ^SD(409.92, "FIA",409.92,0,0) 409.92I "FIA",409.92,0,1) n^n^f^^n^^y^o^n "FIA",409.92,0,10) "FIA",409.92,0,11) N TMP S TMP=$P(^(0),"^",1) I (TMP="0703")!(TMP="0706") "FIA",409.92,0,"RLRO") "FIA",409.92,0,"VR") 5.3^SD "FIA",409.92,409.92) 0 "MBREQ") 0 "PKG",16,-1) 1^1 "PKG",16,0) SCHEDULING^SD^APPOINTMENTS,PROFILES,LETTERS,AMIS REPORTS "PKG",16,20,0) ^9.402P^^ "PKG",16,22,0) ^9.49I^1^1 "PKG",16,22,1,0) 5.3^2930813^2930824 "PKG",16,22,1,"PAH",1,0) 254^3030102 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 8 "RTN","SCDXMSG1") 0^4^B72860271 "RTN","SCDXMSG1",1,0) SCDXMSG1 ;ALB/JRP - AMB CARE MESSAGE BUILDER UTILS;08-MAY-1996 ; 5/2/02 2:08pm "RTN","SCDXMSG1",2,0) ;;5.3;Scheduling;**44,55,70,77,85,66,143,142,162,172,180,239,245,254**;AUG 13, 1993 "RTN","SCDXMSG1",3,0) ; "RTN","SCDXMSG1",4,0) ;-- Line tags for building HL7 segment "RTN","SCDXMSG1",5,0) BLDEVN S VAFEVN=$$EN^VAFHLEVN(EVNTHL7,EVNTDATE,VAFSTR,HL("Q"),HL("FS")) "RTN","SCDXMSG1",6,0) Q "RTN","SCDXMSG1",7,0) BLDPID S VAFPID=$$EN^VAFHLPID(DFN,VAFSTR) "RTN","SCDXMSG1",8,0) D SETMAR^SCMSVUT0("VAFPID","VAFPID",HL("Q"),HL("FS")) "RTN","SCDXMSG1",9,0) Q "RTN","SCDXMSG1",10,0) BLDZPD S VAFZPD=$$EN^VAFHLZPD(DFN,VAFSTR) "RTN","SCDXMSG1",11,0) S VAFZPD=$$SETPOW^SCMSVUT0(DFN,$G(VAFZPD),HL("Q"),HL("FS")) "RTN","SCDXMSG1",12,0) Q "RTN","SCDXMSG1",13,0) BLDPV1 D SETID^SCMSVUT0(ENCPTR,DELPTR) "RTN","SCDXMSG1",14,0) S VAFPV1=$$EN^VAFHLPV1(ENCPTR,DELPTR,VAFSTR,1,HL("Q"),HL("FS")) "RTN","SCDXMSG1",15,0) Q "RTN","SCDXMSG1",16,0) BLDDG1 K @VAFARRY "RTN","SCDXMSG1",17,0) D EN^VAFHLDG1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY) "RTN","SCDXMSG1",18,0) Q "RTN","SCDXMSG1",19,0) BLDPR1 K @VAFARRY "RTN","SCDXMSG1",20,0) D SETPRTY^SCMSVUT0(ENCPTR) "RTN","SCDXMSG1",21,0) D EN^VAFHLPR1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),HL("ECH"),VAFARRY) "RTN","SCDXMSG1",22,0) Q "RTN","SCDXMSG1",23,0) BLDZEL N ELCOD,ELIGENC,I,VAFMSTDT "RTN","SCDXMSG1",24,0) S VAFMSTDT=ENCDT "RTN","SCDXMSG1",25,0) D EN1^VAFHLZEL(DFN,VAFSTR,1,.VAFZEL) "RTN","SCDXMSG1",26,0) S ELCOD=$P($G(^SCE(ENCPTR,0)),"^",13),ELIGENC=$P($G(^DIC(8,+ELCOD,0)),"^",9) "RTN","SCDXMSG1",27,0) S $P(VAFZEL(1),HL("FS"),3)=ELIGENC "RTN","SCDXMSG1",28,0) Q "RTN","SCDXMSG1",29,0) BLDZIR K DGREL,DGINC,DGINR,DGDEP "RTN","SCDXMSG1",30,0) D ALL^DGMTU21(DFN,"V",ENCDT,"R") "RTN","SCDXMSG1",31,0) S VAFZIR=$$EN^VAFHLZIR(+$G(DGINR("V")),VAFSTR,1,ENCPTR) "RTN","SCDXMSG1",32,0) K DGREL,DGINC,DGINR,DGDEP "RTN","SCDXMSG1",33,0) Q "RTN","SCDXMSG1",34,0) BLDZCL K @VAFARRY "RTN","SCDXMSG1",35,0) D EN^VAFHLZCL(DFN,ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY) "RTN","SCDXMSG1",36,0) Q "RTN","SCDXMSG1",37,0) BLDZSC K @VAFARRY "RTN","SCDXMSG1",38,0) D EN^VAFHLZSC(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY) "RTN","SCDXMSG1",39,0) Q "RTN","SCDXMSG1",40,0) BLDZSP S VAFZSP=$$EN^VAFHLZSP(DFN,1,1) "RTN","SCDXMSG1",41,0) S VAFZSP=$$SETVSI^SCMSVUT0(DFN,$G(VAFZSP),HL("Q"),HL("FS")) "RTN","SCDXMSG1",42,0) Q "RTN","SCDXMSG1",43,0) BLDROL K @VAFARRY "RTN","SCDXMSG1",44,0) N SCDXPRV,SCDXPAR,SCDXROL,PTRPRV,NODE,PRVNUM,TMP "RTN","SCDXMSG1",45,0) D GETPRV^SDOE(ENCPTR,"SCDXPRV") "RTN","SCDXMSG1",46,0) S PTRPRV=0 "RTN","SCDXMSG1",47,0) F PRVNUM=1:1 S PTRPRV=+$O(SCDXPRV(PTRPRV)) Q:('PTRPRV) D "RTN","SCDXMSG1",48,0) .K SCDXPAR,SCDXROL "RTN","SCDXMSG1",49,0) .S NODE=SCDXPRV(PTRPRV) "RTN","SCDXMSG1",50,0) .S SCDXPAR("PTR200")=+NODE "RTN","SCDXMSG1",51,0) .S SCDXPAR("INSTID")=$$VID4XMIT^SCDXFU11(XMITPTR)_"-"_(+NODE)_"*"_PRVNUM "RTN","SCDXMSG1",52,0) .S SCDXPAR("ACTION")="CO" "RTN","SCDXMSG1",53,0) .S SCDXPAR("ALTROLE")=($TR($P(NODE,"^",4),"PS","10"))_$E(HL("ECH"),1)_HL("Q")_$E(HL("ECH"),1)_"VA01" "RTN","SCDXMSG1",54,0) .S SCDXPAR("CODEONLY")=0 "RTN","SCDXMSG1",55,0) .S SCDXPAR("RDATE")=ENCDT "RTN","SCDXMSG1",56,0) .D OUTPAT^VAFHLROL("SCDXPAR","SCDXROL",VAFSTR,HL("FS"),HL("ECH"),HL("Q"),240) "RTN","SCDXMSG1",57,0) .K SCDXROL("ERROR"),SCDXROL("WARNING") "RTN","SCDXMSG1",58,0) .M @VAFARRY@(PRVNUM)=SCDXROL "RTN","SCDXMSG1",59,0) Q "RTN","SCDXMSG1",60,0) BLDPD1 S VAFPD1=$$EN^VAFHLPD1(DFN,VAFSTR) "RTN","SCDXMSG1",61,0) Q "RTN","SCDXMSG1",62,0) BLDZEN S VAFZEN=$$EN^VAFHLZEN(DFN,VAFSTR,1,HL("Q"),HL("FS")) "RTN","SCDXMSG1",63,0) Q "RTN","SCDXMSG1",64,0) ; "RTN","SCDXMSG1",65,0) ;-- Line tags for validating HL7 segments "RTN","SCDXMSG1",66,0) VLDEVN S ERROR=$$EN^SCMSVEVN(VAFEVN,HL("Q"),HL("FS"),VALERR) "RTN","SCDXMSG1",67,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",68,0) Q "RTN","SCDXMSG1",69,0) VLDPID S ERROR=$$EN^SCMSVPID(.VAFPID,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT,EVNTHL7) "RTN","SCDXMSG1",70,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",71,0) Q "RTN","SCDXMSG1",72,0) VLDZPD S ERROR=$$EN^SCMSVZPD(VAFZPD,HL("Q"),HL("FS"),VALERR,ENCDT,NODE) "RTN","SCDXMSG1",73,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",74,0) Q "RTN","SCDXMSG1",75,0) VLDPV1 S ERROR=$$EN^SCMSVPV1(VAFPV1,HL("Q"),HL("FS"),VALERR,NODE,EVNTHL7) "RTN","SCDXMSG1",76,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",77,0) Q "RTN","SCDXMSG1",78,0) VLDDG1 S ERROR=$$EN^SCMSVDG1(VAFARRY,HL("Q"),HL("FS"),ENCPTR,VALERR,ENCDT) "RTN","SCDXMSG1",79,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",80,0) Q "RTN","SCDXMSG1",81,0) VLDPR1 S ERROR=$$EN^SCMSVPR1(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT) "RTN","SCDXMSG1",82,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",83,0) Q "RTN","SCDXMSG1",84,0) VLDZEL S ERROR=$$EN^SCMSVZEL(.VAFZEL,HL("Q"),HL("FS"),VALERR,DFN) "RTN","SCDXMSG1",85,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",86,0) Q "RTN","SCDXMSG1",87,0) VLDZIR S ERROR=$$EN^SCMSVZIR(VAFZIR,HL("Q"),HL("FS"),VALERR) "RTN","SCDXMSG1",88,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",89,0) Q "RTN","SCDXMSG1",90,0) VLDZCL S ERROR=$$EN^SCMSVZCL(VAFARRY,HL("Q"),HL("FS"),VALERR,DFN) "RTN","SCDXMSG1",91,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",92,0) Q "RTN","SCDXMSG1",93,0) VLDZSC S ERROR=$$EN^SCMSVZSC(VAFARRY,HL("Q"),HL("FS"),VALERR,ENCPTR) "RTN","SCDXMSG1",94,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",95,0) Q "RTN","SCDXMSG1",96,0) VLDZSP S ERROR=$$EN^SCMSVZSP(VAFZSP,HL("Q"),HL("FS"),VALERR,DFN) "RTN","SCDXMSG1",97,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",98,0) Q "RTN","SCDXMSG1",99,0) VLDROL S ERROR=$$EN^SCMSVROL(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR) "RTN","SCDXMSG1",100,0) S:(ERROR>0) ERROR=0 "RTN","SCDXMSG1",101,0) Q "RTN","SCDXMSG1",102,0) VLDPD1 S ERROR=0 "RTN","SCDXMSG1",103,0) Q "RTN","SCDXMSG1",104,0) VLDZEN S ERROR=0 "RTN","SCDXMSG1",105,0) Q "RTN","SCDXMSG1",106,0) ; "RTN","SCDXMSG1",107,0) ;-- Line tags for copying HL7 segments into HL7 message "RTN","SCDXMSG1",108,0) CPYEVN N I "RTN","SCDXMSG1",109,0) S @XMITARRY@(CURLINE)=VAFEVN "RTN","SCDXMSG1",110,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",111,0) S I="" "RTN","SCDXMSG1",112,0) F S I=+$O(VAFEVN(I)) Q:('I) D "RTN","SCDXMSG1",113,0) .S @XMITARRY@(CURLINE,I)=VAFEVN(I) "RTN","SCDXMSG1",114,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",115,0) Q "RTN","SCDXMSG1",116,0) CPYPID N I "RTN","SCDXMSG1",117,0) S @XMITARRY@(CURLINE)=VAFPID "RTN","SCDXMSG1",118,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",119,0) S I="" "RTN","SCDXMSG1",120,0) F S I=+$O(VAFPID(I)) Q:('I) D "RTN","SCDXMSG1",121,0) .S @XMITARRY@(CURLINE,I)=VAFPID(I) "RTN","SCDXMSG1",122,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",123,0) Q "RTN","SCDXMSG1",124,0) CPYZPD N I "RTN","SCDXMSG1",125,0) S @XMITARRY@(CURLINE)=VAFZPD "RTN","SCDXMSG1",126,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",127,0) S I="" "RTN","SCDXMSG1",128,0) F S I=+$O(VAFZPD(I)) Q:('I) D "RTN","SCDXMSG1",129,0) .S @XMITARRY@(CURLINE,I)=VAFZPD(I) "RTN","SCDXMSG1",130,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",131,0) Q "RTN","SCDXMSG1",132,0) CPYPV1 N I "RTN","SCDXMSG1",133,0) S @XMITARRY@(CURLINE)=VAFPV1 "RTN","SCDXMSG1",134,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",135,0) S I="" "RTN","SCDXMSG1",136,0) F S I=+$O(VAFPV1(I)) Q:('I) D "RTN","SCDXMSG1",137,0) .S @XMITARRY@(CURLINE,I)=VAFPV1(I) "RTN","SCDXMSG1",138,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",139,0) Q "RTN","SCDXMSG1",140,0) CPYDG1 N I,J,K "RTN","SCDXMSG1",141,0) S I="" "RTN","SCDXMSG1",142,0) F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D "RTN","SCDXMSG1",143,0) .S J="" "RTN","SCDXMSG1",144,0) .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D "RTN","SCDXMSG1",145,0) ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J) "RTN","SCDXMSG1",146,0) ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J) "RTN","SCDXMSG1",147,0) ..S LINESADD=LINESADD+1 "RTN","SCDXMSG1",148,0) S CURLINE=CURLINE+K-1 "RTN","SCDXMSG1",149,0) Q "RTN","SCDXMSG1",150,0) CPYPR1 N I,J,K "RTN","SCDXMSG1",151,0) S I="" "RTN","SCDXMSG1",152,0) F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D "RTN","SCDXMSG1",153,0) .S J="" "RTN","SCDXMSG1",154,0) .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D "RTN","SCDXMSG1",155,0) ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J) "RTN","SCDXMSG1",156,0) ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J) "RTN","SCDXMSG1",157,0) ..S LINESADD=LINESADD+1 "RTN","SCDXMSG1",158,0) S CURLINE=CURLINE+K-1 "RTN","SCDXMSG1",159,0) Q "RTN","SCDXMSG1",160,0) CPYZEL N I "RTN","SCDXMSG1",161,0) S @XMITARRY@(CURLINE)=VAFZEL(1) "RTN","SCDXMSG1",162,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",163,0) S I="" "RTN","SCDXMSG1",164,0) F S I=+$O(VAFZEL(1,I)) Q:('I) D "RTN","SCDXMSG1",165,0) .S @XMITARRY@(CURLINE,I)=VAFZEL(1,I) "RTN","SCDXMSG1",166,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",167,0) Q "RTN","SCDXMSG1",168,0) CPYZIR N I "RTN","SCDXMSG1",169,0) S @XMITARRY@(CURLINE)=VAFZIR "RTN","SCDXMSG1",170,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",171,0) N I "RTN","SCDXMSG1",172,0) S I="" "RTN","SCDXMSG1",173,0) F S I=+$O(VAFZIR(I)) Q:('I) D "RTN","SCDXMSG1",174,0) .S @XMITARRY@(CURLINE,I)=VAFZIR(I) "RTN","SCDXMSG1",175,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",176,0) Q "RTN","SCDXMSG1",177,0) CPYZCL N I,J,K "RTN","SCDXMSG1",178,0) S I="" "RTN","SCDXMSG1",179,0) F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D "RTN","SCDXMSG1",180,0) .S J="" "RTN","SCDXMSG1",181,0) .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D "RTN","SCDXMSG1",182,0) ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J) "RTN","SCDXMSG1",183,0) ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J) "RTN","SCDXMSG1",184,0) ..S LINESADD=LINESADD+1 "RTN","SCDXMSG1",185,0) S CURLINE=CURLINE+K-1 "RTN","SCDXMSG1",186,0) Q "RTN","SCDXMSG1",187,0) CPYZSC N I,J,K "RTN","SCDXMSG1",188,0) S I="" "RTN","SCDXMSG1",189,0) F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D "RTN","SCDXMSG1",190,0) .S J="" "RTN","SCDXMSG1",191,0) .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D "RTN","SCDXMSG1",192,0) ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J) "RTN","SCDXMSG1",193,0) ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J) "RTN","SCDXMSG1",194,0) ..S LINESADD=LINESADD+1 "RTN","SCDXMSG1",195,0) S CURLINE=CURLINE+K-1 "RTN","SCDXMSG1",196,0) Q "RTN","SCDXMSG1",197,0) CPYZSP N I "RTN","SCDXMSG1",198,0) S @XMITARRY@(CURLINE)=VAFZSP "RTN","SCDXMSG1",199,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",200,0) S I="" "RTN","SCDXMSG1",201,0) F S I=+$O(VAFZSP(I)) Q:('I) D "RTN","SCDXMSG1",202,0) .S @XMITARRY@(CURLINE,I)=VAFZSP(I) "RTN","SCDXMSG1",203,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",204,0) Q "RTN","SCDXMSG1",205,0) CPYROL N I,J,K "RTN","SCDXMSG1",206,0) S I="" "RTN","SCDXMSG1",207,0) F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D "RTN","SCDXMSG1",208,0) .S J="" "RTN","SCDXMSG1",209,0) .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D "RTN","SCDXMSG1",210,0) ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J) "RTN","SCDXMSG1",211,0) ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J) "RTN","SCDXMSG1",212,0) ..S LINESADD=LINESADD+1 "RTN","SCDXMSG1",213,0) S CURLINE=CURLINE+K-1 "RTN","SCDXMSG1",214,0) Q "RTN","SCDXMSG1",215,0) CPYPD1 N I "RTN","SCDXMSG1",216,0) S @XMITARRY@(CURLINE)=VAFPD1 "RTN","SCDXMSG1",217,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",218,0) S I="" "RTN","SCDXMSG1",219,0) F S I=+$O(VAFPD1(I)) Q:('I) D "RTN","SCDXMSG1",220,0) .S @XMITARRY@(CURLINE,I)=VAFPD1(I) "RTN","SCDXMSG1",221,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",222,0) Q "RTN","SCDXMSG1",223,0) CPYZEN N I "RTN","SCDXMSG1",224,0) S @XMITARRY@(CURLINE)=VAFZEN "RTN","SCDXMSG1",225,0) S LINESADD=LINESADD+1 "RTN","SCDXMSG1",226,0) S I="" "RTN","SCDXMSG1",227,0) F S I=+$O(VAFZEN(I)) Q:('I) D "RTN","SCDXMSG1",228,0) .S @XMITARRY@(CURLINE,I)=VAFZEN(I) "RTN","SCDXMSG1",229,0) .S LINESADD=LINESADD+1 "RTN","SCDXMSG1",230,0) Q "RTN","SCDXMSG1",231,0) ; "RTN","SCDXMSG1",232,0) ;-- Line tags for deleting HL7 segments "RTN","SCDXMSG1",233,0) DELEVN K VAFEVN "RTN","SCDXMSG1",234,0) Q "RTN","SCDXMSG1",235,0) DELPID K VAFPID "RTN","SCDXMSG1",236,0) Q "RTN","SCDXMSG1",237,0) DELZPD K VAFZPD "RTN","SCDXMSG1",238,0) Q "RTN","SCDXMSG1",239,0) DELPV1 K VAFPV1 "RTN","SCDXMSG1",240,0) Q "RTN","SCDXMSG1",241,0) DELDG1 K @VAFARRY "RTN","SCDXMSG1",242,0) Q "RTN","SCDXMSG1",243,0) DELPR1 K @VAFARRY "RTN","SCDXMSG1",244,0) Q "RTN","SCDXMSG1",245,0) DELZEL K VAFZEL "RTN","SCDXMSG1",246,0) Q "RTN","SCDXMSG1",247,0) DELZIR K VAFZIR "RTN","SCDXMSG1",248,0) Q "RTN","SCDXMSG1",249,0) DELZCL K @VAFARRY "RTN","SCDXMSG1",250,0) Q "RTN","SCDXMSG1",251,0) DELZSC K @VAFARRY "RTN","SCDXMSG1",252,0) Q "RTN","SCDXMSG1",253,0) DELZSP K VAFZSP "RTN","SCDXMSG1",254,0) Q "RTN","SCDXMSG1",255,0) DELROL K @VAFARRY "RTN","SCDXMSG1",256,0) Q "RTN","SCDXMSG1",257,0) DELPD1 K VAFPD1 "RTN","SCDXMSG1",258,0) Q "RTN","SCDXMSG1",259,0) DELZEN K VAFZEN "RTN","SCDXMSG1",260,0) Q "RTN","SCDXMSG1",261,0) ; "RTN","SCDXMSG1",262,0) ; "RTN","SCDXMSG1",263,0) SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for a given "RTN","SCDXMSG1",264,0) ; event type "RTN","SCDXMSG1",265,0) ; "RTN","SCDXMSG1",266,0) ;Input : EVNTTYPE - Event type to build list for "RTN","SCDXMSG1",267,0) ; A08 & A23 are the only types currently supported "RTN","SCDXMSG1",268,0) ; (Defaults to A08) "RTN","SCDXMSG1",269,0) ; SEGARRY - Array to place output in (full global reference) "RTN","SCDXMSG1",270,0) ; (Defaults to ^TMP("SCDX SEGMENTS",$J)) "RTN","SCDXMSG1",271,0) ;Output : None "RTN","SCDXMSG1",272,0) ; SEGARRY(Seq,Name) = Fields "RTN","SCDXMSG1",273,0) ; Seq - Sequencing number to order the segments as "RTN","SCDXMSG1",274,0) ; they should be placed in the HL7 message "RTN","SCDXMSG1",275,0) ; Name - Name of HL7 segment "RTN","SCDXMSG1",276,0) ; Fields - List of fields used by Ambulatory Care "RTN","SCDXMSG1",277,0) ; VAFSTR would be set to this value "RTN","SCDXMSG1",278,0) ; : MSH segment is not included "RTN","SCDXMSG1",279,0) ; "RTN","SCDXMSG1",280,0) ;Check input "RTN","SCDXMSG1",281,0) S EVNTTYPE=$G(EVNTTYPE) "RTN","SCDXMSG1",282,0) S:(EVNTTYPE'="A23") EVNTTYPE="A08" "RTN","SCDXMSG1",283,0) S SEGARRY=$G(SEGARRY) "RTN","SCDXMSG1",284,0) S:(SEGARRY="") SEGARRY="^TMP(""SCDX SEGMENTS"","_$J_")" "RTN","SCDXMSG1",285,0) ;Segments used by A08 & A23 "RTN","SCDXMSG1",286,0) S @SEGARRY@(1,"EVN")="1,2" "RTN","SCDXMSG1",287,0) S @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10N,11,12,13,14,16,17,19,22N" "RTN","SCDXMSG1",288,0) S @SEGARRY@(3,"PD1")="3,4" "RTN","SCDXMSG1",289,0) S @SEGARRY@(4,"PV1")="1,2,4,14,19,39,44,50" "RTN","SCDXMSG1",290,0) ;Building list for A23 - add ZPD segment and quit "RTN","SCDXMSG1",291,0) I (EVNTTYPE="A23") D Q "RTN","SCDXMSG1",292,0) .S @SEGARRY@(5,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21" "RTN","SCDXMSG1",293,0) S @SEGARRY@(5,"DG1")="1,2,3,4,5,15" "RTN","SCDXMSG1",294,0) S @SEGARRY@(6,"PR1")="1,3,16" "RTN","SCDXMSG1",295,0) S @SEGARRY@(7,"ROL")="1,2,3,4" "RTN","SCDXMSG1",296,0) S @SEGARRY@(8,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21" "RTN","SCDXMSG1",297,0) S @SEGARRY@(9,"ZEL")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,29" "RTN","SCDXMSG1",298,0) S @SEGARRY@(10,"ZIR")="1,2,3,4,5,6,7,8,9,10,11,12,13" "RTN","SCDXMSG1",299,0) S @SEGARRY@(11,"ZCL")="1,2,3" "RTN","SCDXMSG1",300,0) S @SEGARRY@(12,"ZSC")="1,2,3" "RTN","SCDXMSG1",301,0) S @SEGARRY@(13,"ZSP")="1,2,3,4" "RTN","SCDXMSG1",302,0) S @SEGARRY@(14,"ZEN")="1,2,3,4,5,6,7,8,9,10" "RTN","SCDXMSG1",303,0) Q "RTN","SCDXMSG1",304,0) ; "RTN","SCDXMSG1",305,0) UNWIND(XMITARRY,INSRTPNT) ;Remove all data that was put into HL7 message "RTN","SCDXMSG1",306,0) ; "RTN","SCDXMSG1",307,0) ;Input : XMITARRY - Array containing HL7 message (full global ref) "RTN","SCDXMSG1",308,0) ; (Defaults to ^TMP("HLS",$J)) "RTN","SCDXMSG1",309,0) ; INSRTPNT - Where to begin deletion from (Defaults to 1) "RTN","SCDXMSG1",310,0) ;Output : None "RTN","SCDXMSG1",311,0) ; "RTN","SCDXMSG1",312,0) ;Check input "RTN","SCDXMSG1",313,0) S XMITARRY=$G(XMITARRY) "RTN","SCDXMSG1",314,0) S:(XMITARRY="") XMITARRY="^TMP(""HLS"","_$J_")" "RTN","SCDXMSG1",315,0) S INSRTPNT=$G(INSRTPNT) "RTN","SCDXMSG1",316,0) S:(INSRTPNT="") INSRTPNT=1 "RTN","SCDXMSG1",317,0) ;Remove insertion point from array "RTN","SCDXMSG1",318,0) K @XMITARRY@(INSRTPNT) "RTN","SCDXMSG1",319,0) ;Remove everything from insertion point to end of array "RTN","SCDXMSG1",320,0) F S INSRTPNT=$O(@XMITARRY@(INSRTPNT)) Q:(INSRTPNT="") K @XMITARRY@(INSRTPNT) "RTN","SCDXMSG1",321,0) ;Done "RTN","SCDXMSG1",322,0) Q "RTN","SCMSVPID") 0^5^B10745780 "RTN","SCMSVPID",1,0) SCMSVPID ;ALB/ESD HL7 PID Segment Validation ; 23 Oct 98 3:36 PM "RTN","SCMSVPID",2,0) ;;5.3;Scheduling;**44,66,162,254**;Aug 13, 1993 "RTN","SCMSVPID",3,0) ; "RTN","SCMSVPID",4,0) ; "RTN","SCMSVPID",5,0) EN(PIDSEG,HLQ,HLFS,HLECH,VALERR,ENCDT,EVNTHL7) ; "RTN","SCMSVPID",6,0) ; Entry point to return the HL7 PID (Patient ID) validation segment "RTN","SCMSVPID",7,0) ; "RTN","SCMSVPID",8,0) ; Input: PIDSEG - Array containing PID segment (pass by ref) "RTN","SCMSVPID",9,0) ; PIDSEG = First 245 characters "RTN","SCMSVPID",10,0) ; PIDSEG(1..n) = Continuation nodes "RTN","SCMSVPID",11,0) ; HLQ - HL7 null variable "RTN","SCMSVPID",12,0) ; HLFS - HL7 field separator "RTN","SCMSVPID",13,0) ; HLECH - HL7 encoding characters "RTN","SCMSVPID",14,0) ; VALERR - The array name to put the errors in "RTN","SCMSVPID",15,0) ; ENCDT - The date/time of the encounter. "RTN","SCMSVPID",16,0) ; EVNTHL7 - Event type ("A08" for add/edit, "A23" for delete) "RTN","SCMSVPID",17,0) ; "RTN","SCMSVPID",18,0) ; Output: 1 if PID passed validity check "RTN","SCMSVPID",19,0) ; Error message if PID failed validity check in form of: "RTN","SCMSVPID",20,0) ; -1^"xxx failed validity check" (xxx=element in PID segment) "RTN","SCMSVPID",21,0) ; "RTN","SCMSVPID",22,0) ;Declare variables "RTN","SCMSVPID",23,0) N MSG,SEQ,DFN,STATE,SD,PARSEG,SEG "RTN","SCMSVPID",24,0) S PARSEG=$NA(^TMP("SCMSVPID",$J,"PARSEG")) "RTN","SCMSVPID",25,0) K @PARSEG "RTN","SCMSVPID",26,0) S MSG="-1^Element in PID segment failed validity check" "RTN","SCMSVPID",27,0) ;-Set encoding chars to standard HL7 encoding chars if not passed in "RTN","SCMSVPID",28,0) S HLECH=$G(HLECH) "RTN","SCMSVPID",29,0) S:HLECH="" HLECH="~|\&" "RTN","SCMSVPID",30,0) ;-Create array of elements to validate "RTN","SCMSVPID",31,0) F SEQ=3,5,7,8,10,11,12,16,17,19,22 S SD(SEQ)="" ;Elements for 'add' or 'edit' transactions "RTN","SCMSVPID",32,0) I $G(EVNTHL7)="A23" K SD F I=3,19 S SD(SEQ)="" ;Elements for 'delete' transactions "RTN","SCMSVPID",33,0) ; "RTN","SCMSVPID",34,0) S SEG="PID" "RTN","SCMSVPID",35,0) D VALIDATE^SCMSVUT0(SEG,$G(PIDSEG),"0006",VALERR,.CNT) "RTN","SCMSVPID",36,0) I $D(@VALERR@(SEG)) G ENQ "RTN","SCMSVPID",37,0) ;-Parse out fields "RTN","SCMSVPID",38,0) D SEGPRSE^SCMSVUT5(.PIDSEG,PARSEG,HLFS) "RTN","SCMSVPID",39,0) ;-Remember DFN "RTN","SCMSVPID",40,0) S DFN=$G(@PARSEG@(3)) "RTN","SCMSVPID",41,0) ;-Validate segment name "RTN","SCMSVPID",42,0) S CNT=1 "RTN","SCMSVPID",43,0) D VALIDATE^SCMSVUT0(SEG,$G(@PARSEG@(0)),$P($T(0),";",3),VALERR,.CNT) "RTN","SCMSVPID",44,0) ;-Validate fields "RTN","SCMSVPID",45,0) S SEQ=0 "RTN","SCMSVPID",46,0) F S SEQ=+$O(SD(SEQ)) Q:'SEQ D "RTN","SCMSVPID",47,0) .S DATA=$$CONVERT^SCMSVUT0($G(@PARSEG@(SEQ)),HLFS,HLQ) "RTN","SCMSVPID",48,0) .I SEQ=11 D ADDRCHK($G(@PARSEG@(11)),SEG,VALERR,.CNT,.STATE) Q "RTN","SCMSVPID",49,0) .I (SEQ=10)!(SEQ=22) D Q "RTN","SCMSVPID",50,0) ..N PARSEQ,REP,COMP "RTN","SCMSVPID",51,0) ..S PARSEQ=$NA(^TMP("SCMSVPID",$J,"PARSEQ")) "RTN","SCMSVPID",52,0) ..K @PARSEQ "RTN","SCMSVPID",53,0) ..D SEQPRSE^SCMSVUT5($G(@PARSEG@(SEQ)),PARSEQ,HLECH) "RTN","SCMSVPID",54,0) ..S REP=0 "RTN","SCMSVPID",55,0) ..F S REP=+$O(@PARSEQ@(REP)) Q:'REP D "RTN","SCMSVPID",56,0) ...S DATA=$$CONVERT^SCMSVUT0($G(@PARSEQ@(REP,1)),HLFS,HLQ) "RTN","SCMSVPID",57,0) ...D VALIDATE^SCMSVUT0(SEG,$P(DATA,$E(HLECH,1),1),$P($T(@(SEQ)),";",3),VALERR,.CNT) "RTN","SCMSVPID",58,0) ..K @PARSEQ "RTN","SCMSVPID",59,0) .S:SEQ=3 DATA=$P(DATA,$E(HLECH,1,1),1) "RTN","SCMSVPID",60,0) .S:SEQ=5 DATA=$$FMNAME^HLFNC(DATA) "RTN","SCMSVPID",61,0) .S:SEQ=7 DATA=$$FMDATE^HLFNC(DATA) "RTN","SCMSVPID",62,0) .D VALIDATE^SCMSVUT0(SEG,DATA,$P($T(@(SEQ)),";",3),VALERR,.CNT) "RTN","SCMSVPID",63,0) ; "RTN","SCMSVPID",64,0) ENQ K @PARSEG "RTN","SCMSVPID",65,0) Q $S($D(@VALERR@(SEG,1)):MSG,1:1) "RTN","SCMSVPID",66,0) ; "RTN","SCMSVPID",67,0) ; "RTN","SCMSVPID",68,0) ADDRCHK(PIDADDR,SEG,VALERR,CNT,STATE) ;- Validity chk for street addr 1, city, state, zip "RTN","SCMSVPID",69,0) ; "RTN","SCMSVPID",70,0) N LP "RTN","SCMSVPID",71,0) F LP=111,112,113,114,115 DO "RTN","SCMSVPID",72,0) .D VALIDATE^SCMSVUT0(SEG,$P(PIDADDR,$E(HLECH,1),$E(LP,3,3)),$P($T(@(LP)),";",3),VALERR,.CNT) "RTN","SCMSVPID",73,0) .I LP=114 S STATE=$P(PIDADDR,$E(HLECH,1),4) I STATE]"" S STATE=+$O(^DIC(5,"C",STATE,"")) "RTN","SCMSVPID",74,0) .Q "RTN","SCMSVPID",75,0) Q "RTN","SCMSVPID",76,0) ; "RTN","SCMSVPID",77,0) ; "RTN","SCMSVPID",78,0) ; "RTN","SCMSVPID",79,0) ERR ;;Invalid or missing patient ID data for encounter (HL7 PID data segment) "RTN","SCMSVPID",80,0) ; "RTN","SCMSVPID",81,0) ; "RTN","SCMSVPID",82,0) ;- PID data elements validated "RTN","SCMSVPID",83,0) ; "RTN","SCMSVPID",84,0) 0 ;;0035;HL7 SEGMENT NAME "RTN","SCMSVPID",85,0) 3 ;;2030;PATIENT ID (INTERNAL) "RTN","SCMSVPID",86,0) 5 ;;2000;NAME "RTN","SCMSVPID",87,0) 7 ;;2050;DATE OF BIRTH "RTN","SCMSVPID",88,0) 8 ;;2100;SEX "RTN","SCMSVPID",89,0) 10 ;;2150;RACE "RTN","SCMSVPID",90,0) 111 ;;2200;STREET ADDRESS 1 "RTN","SCMSVPID",91,0) 112 ;;2210;STREET ADDRESS 2 "RTN","SCMSVPID",92,0) 113 ;;2220;CITY "RTN","SCMSVPID",93,0) 114 ;;2230;STATE "RTN","SCMSVPID",94,0) 115 ;;2240;ZIP CODE "RTN","SCMSVPID",95,0) 12 ;;2250;COUNTY CODE "RTN","SCMSVPID",96,0) 16 ;;2300;MARITAL STATUS "RTN","SCMSVPID",97,0) 17 ;;2330;RELIGION "RTN","SCMSVPID",98,0) 19 ;;2360;SSN "RTN","SCMSVPID",99,0) 22 ;;2380;ETHNICITY "RTN","SCMSVUT0") 0^6^B44832749 "RTN","SCMSVUT0",1,0) SCMSVUT0 ;ALB/ESD HL7 Segment Validation Utilities ;05/09/96 "RTN","SCMSVUT0",2,0) ;;5.3;Scheduling;**44,55,66,132,245,254**;Aug 13, 1993 "RTN","SCMSVUT0",3,0) ; "RTN","SCMSVUT0",4,0) ; "RTN","SCMSVUT0",5,0) CONVERT(SEG,HLFS,HLQ) ; Convert HLQ ("") to null in segment "RTN","SCMSVUT0",6,0) ; Input: SEG = HL7 segment "RTN","SCMSVUT0",7,0) ; HLFS = HL7 field separator "RTN","SCMSVUT0",8,0) ; HLQ = HL7 "" character "RTN","SCMSVUT0",9,0) ; "RTN","SCMSVUT0",10,0) ; Output: SEG = Segment where HLQ replaced with null "RTN","SCMSVUT0",11,0) ; "RTN","SCMSVUT0",12,0) ; "RTN","SCMSVUT0",13,0) N I "RTN","SCMSVUT0",14,0) F I=1:1:55 I $P(SEG,HLFS,I)=HLQ S $P(SEG,HLFS,I)="" "RTN","SCMSVUT0",15,0) Q SEG "RTN","SCMSVUT0",16,0) ; "RTN","SCMSVUT0",17,0) SETID(SDOE,SDDELOE) ; Set PCE Unique Visit Number in field #.2 of #409.68 "RTN","SCMSVUT0",18,0) ; Input: SDOE = IEN of Outpatient Encounter (#409.68) file "RTN","SCMSVUT0",19,0) ; SDDELOE = IEN of Deleted Outpatient Encounter (#409.74) file "RTN","SCMSVUT0",20,0) ; "RTN","SCMSVUT0",21,0) ; Output: Unique Visit Number set in field #.2 of #409.68 "RTN","SCMSVUT0",22,0) ; or field #.2 of #409.74 "RTN","SCMSVUT0",23,0) ; "RTN","SCMSVUT0",24,0) ; "RTN","SCMSVUT0",25,0) N SDOEC,SDARRY "RTN","SCMSVUT0",26,0) S SDOEC=0 "RTN","SCMSVUT0",27,0) S SDOE=+$G(SDOE) "RTN","SCMSVUT0",28,0) S SDDELOE=+$G(SDDELOE) "RTN","SCMSVUT0",29,0) ; "RTN","SCMSVUT0",30,0) ;-Outpatient Enc pointer passed in; use file #409.68 "RTN","SCMSVUT0",31,0) S SDARRY="^SCE("_SDOE_",0)" "RTN","SCMSVUT0",32,0) ; "RTN","SCMSVUT0",33,0) ;-Deleted Outpatient Enc pointer passed in; use file #409.74 "RTN","SCMSVUT0",34,0) S:(SDDELOE) SDARRY="^SD(409.74,"_SDDELOE_",1)" "RTN","SCMSVUT0",35,0) ; "RTN","SCMSVUT0",36,0) ;-Quit if no encounter record or deleted encounter record "RTN","SCMSVUT0",37,0) Q:($G(@SDARRY)="") "RTN","SCMSVUT0",38,0) ;-Add unique ID to parent "RTN","SCMSVUT0",39,0) D GETID "RTN","SCMSVUT0",40,0) ; "RTN","SCMSVUT0",41,0) ;-Add unique ID to children for Outpatient Enc only (quit if no child encounter record) "RTN","SCMSVUT0",42,0) I (SDOE) F S SDOEC=+$O(^SCE("APAR",SDOE,SDOEC)) Q:'SDOEC S SDARRY="^SCE("_SDOEC_",0)" Q:($G(@SDARRY)="") D GETID "RTN","SCMSVUT0",43,0) Q "RTN","SCMSVUT0",44,0) ; "RTN","SCMSVUT0",45,0) GETID ;Get unique visit ID "RTN","SCMSVUT0",46,0) S:$P($G(@SDARRY),"^",20)="" $P(@SDARRY,"^",20)=$$IEN2VID^VSIT($P(@SDARRY,"^",5)) "RTN","SCMSVUT0",47,0) Q "RTN","SCMSVUT0",48,0) ; "RTN","SCMSVUT0",49,0) SETPRTY(SDOE) ;Set outpatient provider type in field #.06 of V PROVIDER "RTN","SCMSVUT0",50,0) ; Input: SDOE = IEN of Outpatient Encounter (#409.68) file "RTN","SCMSVUT0",51,0) ; "RTN","SCMSVUT0",52,0) ; Output: Provider Type set in field #.06 of V PROVIDER "RTN","SCMSVUT0",53,0) ; "RTN","SCMSVUT0",54,0) ; "RTN","SCMSVUT0",55,0) N SDPRTYP,SDVPRV,SDPRVS "RTN","SCMSVUT0",56,0) S SDOE=+$G(SDOE),SDVPRV=0 "RTN","SCMSVUT0",57,0) ; "RTN","SCMSVUT0",58,0) ;- Get all provider IENs for encounter "RTN","SCMSVUT0",59,0) D GETPRV^SDOE(SDOE,"SDPRVS") "RTN","SCMSVUT0",60,0) F S SDVPRV=+$O(SDPRVS(SDVPRV)) Q:'SDVPRV D "RTN","SCMSVUT0",61,0) . S SDPRTYP=0 "RTN","SCMSVUT0",62,0) . ; "RTN","SCMSVUT0",63,0) . ;- If no prov type, call API and add provider type to record "RTN","SCMSVUT0",64,0) . S:$P(SDPRVS(SDVPRV),"^",6)="" SDPRTYP=$$GET^XUA4A72(+SDPRVS(SDVPRV),+$G(^SCE(SDOE,0))) "RTN","SCMSVUT0",65,0) . I +$G(SDPRTYP)>0 D PCLASS^PXAPIOE(SDVPRV) "RTN","SCMSVUT0",66,0) Q "RTN","SCMSVUT0",67,0) ; "RTN","SCMSVUT0",68,0) SETMAR(PIDSEG,PID1SEG,HLQ,HLFS) ; Set marital status prior to PID segment validation "RTN","SCMSVUT0",69,0) ; Input: PIDSEG = PID segment (< or = 245 chars) "RTN","SCMSVUT0",70,0) ; PID1SEG = Remainder of PID segment (> 245 chars) "RTN","SCMSVUT0",71,0) ; HLQ = HL7 null variable "RTN","SCMSVUT0",72,0) ; HLFS = HL7 field separator "RTN","SCMSVUT0",73,0) ; "RTN","SCMSVUT0",74,0) ; Output: Marital status changed from null to "U" (UNKNOWN) prior to validation of PID segment and transmittal to AAC "RTN","SCMSVUT0",75,0) ; "RTN","SCMSVUT0",76,0) ; "RTN","SCMSVUT0",77,0) N LSTP "RTN","SCMSVUT0",78,0) S PIDSEG=$G(PIDSEG) "RTN","SCMSVUT0",79,0) S:PIDSEG="" PIDSEG="VAFPID" "RTN","SCMSVUT0",80,0) S PID1SEG=$G(PID1SEG) "RTN","SCMSVUT0",81,0) S:PID1SEG="" PID1SEG="VAFPID" "RTN","SCMSVUT0",82,0) G SETMARQ:(($G(@PIDSEG)="")&($G(@PID1SEG@(1))="")) "RTN","SCMSVUT0",83,0) ; "RTN","SCMSVUT0",84,0) ;- Piece 17 of PID segment is marital status (piece 1 = segment name) "RTN","SCMSVUT0",85,0) I $G(@PID1SEG@(1))="" S:($P(@PIDSEG,HLFS,17)=""!($P(@PIDSEG,HLFS,17)=HLQ)) $P(@PIDSEG,HLFS,17)="U" G SETMARQ "RTN","SCMSVUT0",86,0) I $G(@PID1SEG@(1))]"" D "RTN","SCMSVUT0",87,0) . S LSTP=+($L(@PIDSEG,HLFS)) "RTN","SCMSVUT0",88,0) .; "RTN","SCMSVUT0",89,0) .;- If PID segment = or > 17th piece, check marital status in PIDSEG "RTN","SCMSVUT0",90,0) . I ((LSTP=17)!(LSTP>17)) S:($P(@PIDSEG,HLFS,17)=""!($P(@PIDSEG,HLFS,17)=HLQ)) $P(@PIDSEG,HLFS,17)="U" Q "RTN","SCMSVUT0",91,0) .; "RTN","SCMSVUT0",92,0) .;- If PID segment < 17th piece, check marital status in PID1SEG "RTN","SCMSVUT0",93,0) . I (LSTP<17) S:($P(@PID1SEG@(1),HLFS,(17-(LSTP-1)))=""!($P(@PID1SEG@(1),HLFS,(17-(LSTP-1)))=HLQ)) $P(@PID1SEG@(1),HLFS,(17-(LSTP-1)))="U" "RTN","SCMSVUT0",94,0) ; "RTN","SCMSVUT0",95,0) SETMARQ Q "RTN","SCMSVUT0",96,0) ; "RTN","SCMSVUT0",97,0) SETPOW(DFN,ZPDSEG,HLQ,HLFS) ; Set POW Status Indicated field prior to ZPD segment validation "RTN","SCMSVUT0",98,0) ; "RTN","SCMSVUT0",99,0) ; Input: DFN = IEN of Patient (#2) file "RTN","SCMSVUT0",100,0) ; ZPDSEG = HL7 ZPD segment "RTN","SCMSVUT0",101,0) ; HLQ = HL7 null variable "RTN","SCMSVUT0",102,0) ; HLFS = HL7 field separator "RTN","SCMSVUT0",103,0) ; "RTN","SCMSVUT0",104,0) ; Output: If Veteran and POW Status Indicated field = null, set to "RTN","SCMSVUT0",105,0) ; U (Unknown) "RTN","SCMSVUT0",106,0) ; If Non-Veteran, set to null "RTN","SCMSVUT0",107,0) ; "RTN","SCMSVUT0",108,0) S DFN=$G(DFN),ZPDSEG=$G(ZPDSEG) "RTN","SCMSVUT0",109,0) G SETPOWQ:(DFN="")!(ZPDSEG="") "RTN","SCMSVUT0",110,0) I $P($G(^DPT(DFN,"VET")),"^")="Y",($P(ZPDSEG,HLFS,18)=""!($P(ZPDSEG,HLFS,18)=HLQ)) S $P(ZPDSEG,HLFS,18)="U" "RTN","SCMSVUT0",111,0) I $P($G(^DPT(DFN,"VET")),"^")="N" S $P(ZPDSEG,HLFS,18)=HLQ "RTN","SCMSVUT0",112,0) ; "RTN","SCMSVUT0",113,0) SETPOWQ Q ZPDSEG "RTN","SCMSVUT0",114,0) ; "RTN","SCMSVUT0",115,0) ; "RTN","SCMSVUT0",116,0) SETVSI(DFN,ZSPSEG,HLQ,HLFS) ;Set Vietnam Service Indicated field prior to ZSP segment validation "RTN","SCMSVUT0",117,0) ; "RTN","SCMSVUT0",118,0) ; Input: DFN = IEN of Patient (#2) file "RTN","SCMSVUT0",119,0) ; ZSPSEG = HL7 ZSP segment "RTN","SCMSVUT0",120,0) ; HLQ = HL7 null variable "RTN","SCMSVUT0",121,0) ; HLFS = HL7 field separator "RTN","SCMSVUT0",122,0) ; "RTN","SCMSVUT0",123,0) ; Output: If Veteran and Vietnam Service Indicated field = null, "RTN","SCMSVUT0",124,0) ; set to U (Unknown) "RTN","SCMSVUT0",125,0) ; If Non-Veteran, set to null "RTN","SCMSVUT0",126,0) ; "RTN","SCMSVUT0",127,0) S DFN=$G(DFN),ZSPSEG=$G(ZSPSEG) "RTN","SCMSVUT0",128,0) G SETVSIQ:(DFN="")!(ZSPSEG="") "RTN","SCMSVUT0",129,0) I $P($G(^DPT(DFN,"VET")),"^")="Y",($P(ZSPSEG,HLFS,6)=""!($P(ZSPSEG,HLFS,6)=HLQ)) S $P(ZSPSEG,HLFS,6)="U" "RTN","SCMSVUT0",130,0) I $P($G(^DPT(DFN,"VET")),"^")="N" S $P(ZSPSEG,HLFS,6)=HLQ "RTN","SCMSVUT0",131,0) ; "RTN","SCMSVUT0",132,0) SETVSIQ Q ZSPSEG "RTN","SCMSVUT0",133,0) ; "RTN","SCMSVUT0",134,0) ; "RTN","SCMSVUT0",135,0) ; "RTN","SCMSVUT0",136,0) ;The following subroutines all have to do with the validation of "RTN","SCMSVUT0",137,0) ;data using the same edit checks that are used by Austin. "RTN","SCMSVUT0",138,0) ; "RTN","SCMSVUT0",139,0) HL7SEGNM(SEG,DATA) ;checks the validity of the HL7 segment name passed in. "RTN","SCMSVUT0",140,0) ;INPUT SEG - the HL7 segment name "RTN","SCMSVUT0",141,0) ; DATA - the data to compare. In this case the HL7 segment name. "RTN","SCMSVUT0",142,0) ; "RTN","SCMSVUT0",143,0) ;OUTPUT 0 (ZERO) if not validate "RTN","SCMSVUT0",144,0) ; 1 if validated "RTN","SCMSVUT0",145,0) ; "RTN","SCMSVUT0",146,0) I '$D(SEG)!('$D(DATA)) Q 0 "RTN","SCMSVUT0",147,0) Q $S(SEG=DATA:1,1:0) "RTN","SCMSVUT0",148,0) ; "RTN","SCMSVUT0",149,0) EVTTYP(SEG,DATA) ;checks the event type of the segment passed in. "RTN","SCMSVUT0",150,0) ;INPUT SEG - The HL7 segment name in question "RTN","SCMSVUT0",151,0) ; DATA - The event type from the HL7 segment in question. "RTN","SCMSVUT0",152,0) ; "RTN","SCMSVUT0",153,0) ;OUTPUT 0 (ZERO) if not validate "RTN","SCMSVUT0",154,0) ; 1 if validated "RTN","SCMSVUT0",155,0) ; "RTN","SCMSVUT0",156,0) I '$D(SEG)!('$D(DATA)) Q 0 "RTN","SCMSVUT0",157,0) I SEG="EVN"&(DATA="A08"!(DATA="A23")) Q 1 "RTN","SCMSVUT0",158,0) Q 0 "RTN","SCMSVUT0",159,0) ; "RTN","SCMSVUT0",160,0) EVTDTTM(DATA) ;Checks the date and time to ensure it is correct. "RTN","SCMSVUT0",161,0) ;INPUT DATA - this is the date and time in quesiton. "RTN","SCMSVUT0",162,0) ; "RTN","SCMSVUT0",163,0) ;OUTPUT 0 (ZERO) if not validate "RTN","SCMSVUT0",164,0) ; 1 if validated "RTN","SCMSVUT0",165,0) ; "RTN","SCMSVUT0",166,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",167,0) N STRTDT,%DT,X,Y "RTN","SCMSVUT0",168,0) S STRTDT=+$O(^SD(404.91,0)) "RTN","SCMSVUT0",169,0) S STRTDT=$P($G(^SD(404.91,STRTDT,"AMB")),U,2) "RTN","SCMSVUT0",170,0) I 'STRTDT Q 0 "RTN","SCMSVUT0",171,0) S %DT="T",%DT(0)=STRTDT,X=DATA "RTN","SCMSVUT0",172,0) D ^%DT "RTN","SCMSVUT0",173,0) Q $S(Y=-1:0,1:1) "RTN","SCMSVUT0",174,0) ; "RTN","SCMSVUT0",175,0) VALIDATE(SEG,DATA,ERRCOD,VALERR,CTR) ; "RTN","SCMSVUT0",176,0) ; "RTN","SCMSVUT0",177,0) N ERRIEN,ERRCHK,RES "RTN","SCMSVUT0",178,0) S ERRIEN=+$O(^SD(409.76,"B",ERRCOD,"")) "RTN","SCMSVUT0",179,0) I 'ERRIEN S @VALERR@(SEG,CTR)=ERRCOD D INCR Q "RTN","SCMSVUT0",180,0) S ERRCHK=$G(^SD(409.76,ERRIEN,"CHK")) "RTN","SCMSVUT0",181,0) I ERRCHK="" S @VALERR@(SEG,CTR)=ERRCOD D INCR Q "RTN","SCMSVUT0",182,0) X ERRCHK "RTN","SCMSVUT0",183,0) I 'RES S @VALERR@(SEG,CTR)=ERRCOD D INCR "RTN","SCMSVUT0",184,0) Q "RTN","SCMSVUT0",185,0) ; "RTN","SCMSVUT0",186,0) DFN(DATA) ; "RTN","SCMSVUT0",187,0) ;INPUT DATA - the DFN of the patient "RTN","SCMSVUT0",188,0) ; "RTN","SCMSVUT0",189,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",190,0) I DATA=""!(DATA=0) Q 0 "RTN","SCMSVUT0",191,0) I DATA'?1.N.".".N Q 0 "RTN","SCMSVUT0",192,0) Q 1 "RTN","SCMSVUT0",193,0) ; "RTN","SCMSVUT0",194,0) PATNM(DATA) ; "RTN","SCMSVUT0",195,0) ;INPUT DATA - The name of the patient "RTN","SCMSVUT0",196,0) ; "RTN","SCMSVUT0",197,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",198,0) I DATA="" Q 0 "RTN","SCMSVUT0",199,0) I DATA?.N.",".N Q 0 "RTN","SCMSVUT0",200,0) I DATA?1.C Q 0 "RTN","SCMSVUT0",201,0) Q 1 "RTN","SCMSVUT0",202,0) ; "RTN","SCMSVUT0",203,0) DOB(DATA,ENCDT) ; "RTN","SCMSVUT0",204,0) ;INPUT DATA - The DOB to be tested. "RTN","SCMSVUT0",205,0) ; ENCDT - The date/time of the encounter "RTN","SCMSVUT0",206,0) ; "RTN","SCMSVUT0",207,0) N %DT,X,Y "RTN","SCMSVUT0",208,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",209,0) I '$D(ENCDT) Q 0 "RTN","SCMSVUT0",210,0) I DATA'?1.N Q 0 "RTN","SCMSVUT0",211,0) S %DT="T",%DT(0)=-ENCDT,X=DATA "RTN","SCMSVUT0",212,0) D ^%DT "RTN","SCMSVUT0",213,0) Q $S(Y=-1:0,1:1) "RTN","SCMSVUT0",214,0) ; "RTN","SCMSVUT0",215,0) SEX(DATA) ; "RTN","SCMSVUT0",216,0) ;INPUT DATA - The sex code to be validated "RTN","SCMSVUT0",217,0) ; "RTN","SCMSVUT0",218,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",219,0) I "FMUO"'[DATA Q 0 "RTN","SCMSVUT0",220,0) Q 1 "RTN","SCMSVUT0",221,0) ; "RTN","SCMSVUT0",222,0) RACE(DATA) ; "RTN","SCMSVUT0",223,0) ;INPUT DATA - the race code to be validated (NNNN-C-XXX) "RTN","SCMSVUT0",224,0) ; "RTN","SCMSVUT0",225,0) N VAL,MTHD "RTN","SCMSVUT0",226,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",227,0) I DATA="" Q 1 "RTN","SCMSVUT0",228,0) S VAL=$P(DATA,"-",1,2) "RTN","SCMSVUT0",229,0) S MTHD=$P(DATA,"-",3) "RTN","SCMSVUT0",230,0) I VAL'?4N1"-"1N Q 0 "RTN","SCMSVUT0",231,0) I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0 "RTN","SCMSVUT0",232,0) Q 1 "RTN","SCMSVUT0",233,0) ; "RTN","SCMSVUT0",234,0) STR1(DATA) ; "RTN","SCMSVUT0",235,0) ;INPUT DATA - Street address line 1 "RTN","SCMSVUT0",236,0) ; "RTN","SCMSVUT0",237,0) N LP,VAR "RTN","SCMSVUT0",238,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",239,0) I DATA="" Q 0 "RTN","SCMSVUT0",240,0) I DATA?1.N Q 0 "RTN","SCMSVUT0",241,0) I DATA=" " Q 0 "RTN","SCMSVUT0",242,0) F LP=1:1:$L(DATA) S VAR=$E(DATA,LP,LP) I $A(VAR)>32,($A(VAR)<127) S LP="Y" Q "RTN","SCMSVUT0",243,0) Q $S(LP="Y":1,1:0) "RTN","SCMSVUT0",244,0) ; "RTN","SCMSVUT0",245,0) STR2(DATA) ; "RTN","SCMSVUT0",246,0) ;INPUT DATA - Street address line 2 "RTN","SCMSVUT0",247,0) I DATA?1.N Q 0 "RTN","SCMSVUT0",248,0) Q 1 "RTN","SCMSVUT0",249,0) ; "RTN","SCMSVUT0",250,0) CITY(DATA) ; "RTN","SCMSVUT0",251,0) ;INPUT DATA - The city code to be validated "RTN","SCMSVUT0",252,0) ; "RTN","SCMSVUT0",253,0) I DATA="" Q 0 "RTN","SCMSVUT0",254,0) I DATA?1.N Q 0 "RTN","SCMSVUT0",255,0) Q 1 "RTN","SCMSVUT0",256,0) ; "RTN","SCMSVUT0",257,0) STATE(DATA) ; "RTN","SCMSVUT0",258,0) ;INPUT DATA - State code to be validated. "RTN","SCMSVUT0",259,0) ; "RTN","SCMSVUT0",260,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",261,0) I DATA="" Q 0 "RTN","SCMSVUT0",262,0) I '$D(^DIC(5,"C",DATA)) Q 0 "RTN","SCMSVUT0",263,0) Q 1 "RTN","SCMSVUT0",264,0) ; "RTN","SCMSVUT0",265,0) ZIP(DATA) ; "RTN","SCMSVUT0",266,0) ;INPUT DATA - The zipo code to be validated "RTN","SCMSVUT0",267,0) ; "RTN","SCMSVUT0",268,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",269,0) I $E(DATA,1,5)="00000" Q 0 "RTN","SCMSVUT0",270,0) I DATA'?5N."-".4N Q 0 "RTN","SCMSVUT0",271,0) Q 1 "RTN","SCMSVUT0",272,0) ; "RTN","SCMSVUT0",273,0) COUNTY(DATA,STATE) ; "RTN","SCMSVUT0",274,0) ;INPUT DATA - The county code to be validated "RTN","SCMSVUT0",275,0) ; STATE - STATE file IEN "RTN","SCMSVUT0",276,0) ; "RTN","SCMSVUT0",277,0) I DATA="" Q 0 "RTN","SCMSVUT0",278,0) I STATE="" Q 0 "RTN","SCMSVUT0",279,0) I '$D(^DIC(5,+$G(STATE),1,"C",DATA)) Q 0 "RTN","SCMSVUT0",280,0) Q 1 "RTN","SCMSVUT0",281,0) ; "RTN","SCMSVUT0",282,0) MARITAL(DATA) ; "RTN","SCMSVUT0",283,0) ;INPUT DATA - The marital status code to be validated. "RTN","SCMSVUT0",284,0) ; "RTN","SCMSVUT0",285,0) I $L(DATA)>1 Q 0 "RTN","SCMSVUT0",286,0) I "ADMSWU"'[DATA Q 0 "RTN","SCMSVUT0",287,0) Q 1 "RTN","SCMSVUT0",288,0) ; "RTN","SCMSVUT0",289,0) REL(DATA) ; "RTN","SCMSVUT0",290,0) ;INPUT DATA - The religion abbreviation to the validated "RTN","SCMSVUT0",291,0) ; "RTN","SCMSVUT0",292,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",293,0) I DATA="" Q 0 "RTN","SCMSVUT0",294,0) I '$D(^DIC(13,"C",+DATA)) Q 0 "RTN","SCMSVUT0",295,0) Q 1 "RTN","SCMSVUT0",296,0) ; "RTN","SCMSVUT0",297,0) SSN(DATA,NOPCHK) ; "RTN","SCMSVUT0",298,0) ;INPUT DATA - The SSN to be validated "RTN","SCMSVUT0",299,0) ; NOPCHK - O = Check pseudo indicator (default) "RTN","SCMSVUT0",300,0) ; 1 = Don't check pseudo indicator "RTN","SCMSVUT0",301,0) ; "RTN","SCMSVUT0",302,0) I '$D(DATA) Q 0 "RTN","SCMSVUT0",303,0) N SSN,PSD "RTN","SCMSVUT0",304,0) S SSN=$E(DATA,1,9),PSD=$E(DATA,10) "RTN","SCMSVUT0",305,0) I SSN'?9N Q 0 "RTN","SCMSVUT0",306,0) I '$G(NOPCHK) I (PSD'=" "),(PSD'=""),(PSD'="P") Q 0 "RTN","SCMSVUT0",307,0) I $E(SSN,1,5)="00000" Q 0 "RTN","SCMSVUT0",308,0) Q 1 "RTN","SCMSVUT0",309,0) ; "RTN","SCMSVUT0",310,0) INCR ;increases the counter "RTN","SCMSVUT0",311,0) S CTR=CTR+1 "RTN","SCMSVUT0",312,0) Q "RTN","SCMSVUT0",313,0) ; "RTN","SCMSVUT0",314,0) REMOVE(SEG,ERR,VALERR,CNT) ; "RTN","SCMSVUT0",315,0) ;INPUT SEG - The segment being worked on "RTN","SCMSVUT0",316,0) ; VALERR - The array holding the information "RTN","SCMSVUT0",317,0) ; CNT - the counter to use "RTN","SCMSVUT0",318,0) ; ERR - error code to remove "RTN","SCMSVUT0",319,0) ; "RTN","SCMSVUT0",320,0) N LP "RTN","SCMSVUT0",321,0) F LP=1:1:CNT I $G(@VALERR@(SEG,LP))=ERR K @VALERR@(SEG,LP) "RTN","SCMSVUT0",322,0) Q "RTN","SCMSVUT0",323,0) ; "RTN","SCMSVUT0",324,0) DECR(CNT) ; "RTN","SCMSVUT0",325,0) S CNT=CNT-1 "RTN","SCMSVUT0",326,0) Q "RTN","SCMSVUT0",327,0) ; "RTN","SCMSVUT2") 0^7^B16403958 "RTN","SCMSVUT2",1,0) SCMSVUT2 ;ALB/JLU;Utility routine for AMBCARE;06/28/99 "RTN","SCMSVUT2",2,0) ;;5.3;Scheduling;**66,180,254**;AUG 13,1993 "RTN","SCMSVUT2",3,0) ;06/28/99 ACS Added CPT modifier validation "RTN","SCMSVUT2",4,0) ; "RTN","SCMSVUT2",5,0) COUNT(VALER) ;counts the number of errored encounters found. "RTN","SCMSVUT2",6,0) ;INPUT VALER - The array containing the errors. "RTN","SCMSVUT2",7,0) ;OUTPUT the number of errors "RTN","SCMSVUT2",8,0) ; "RTN","SCMSVUT2",9,0) N VAR,CNT "RTN","SCMSVUT2",10,0) S VAR="",CNT=0 "RTN","SCMSVUT2",11,0) F S VAR=$O(@VALER@(VAR)) Q:VAR']"" S CNT=CNT+1 "RTN","SCMSVUT2",12,0) Q CNT "RTN","SCMSVUT2",13,0) ; "RTN","SCMSVUT2",14,0) FILEVERR(PTR,VALERR) ;files the errors found for an encounter "RTN","SCMSVUT2",15,0) ;INPUT PTR - The pointer to the entry in the transmission file 409.73 "RTN","SCMSVUT2",16,0) ; VALERR - The array holding the errors for the encounter. "RTN","SCMSVUT2",17,0) ;OUTPUT 0 - did not file "RTN","SCMSVUT2",18,0) ; 1 - did file "RTN","SCMSVUT2",19,0) N SEG,FILE "RTN","SCMSVUT2",20,0) I '$D(VALERR) Q 0 "RTN","SCMSVUT2",21,0) S SEG="",FILE=-1 "RTN","SCMSVUT2",22,0) F S SEG=$O(@VALERR@(SEG)) Q:SEG']"" D FILE(VALERR,SEG,PTR,.FILE) "RTN","SCMSVUT2",23,0) Q $S(FILE=1:1,1:0) "RTN","SCMSVUT2",24,0) ; "RTN","SCMSVUT2",25,0) FILE(VALERR,SEG,PTR,FILE) ; "RTN","SCMSVUT2",26,0) N NBR "RTN","SCMSVUT2",27,0) S NBR=0 "RTN","SCMSVUT2",28,0) F S NBR=$O(@VALERR@(SEG,NBR)) Q:'NBR DO "RTN","SCMSVUT2",29,0) .N CODPTR "RTN","SCMSVUT2",30,0) .S CODE=$G(@VALERR@(SEG,NBR)) "RTN","SCMSVUT2",31,0) .I CODE']"" Q "RTN","SCMSVUT2",32,0) .S CODPTR=$O(^SD(409.76,"B",CODE,"")) "RTN","SCMSVUT2",33,0) .I 'CODPTR Q "RTN","SCMSVUT2",34,0) .I $D(^SD(409.75,"AER",PTR,CODPTR)) S FILE=1 Q "RTN","SCMSVUT2",35,0) .S FILE=$$CRTERR^SCDXFU02(PTR,CODE) "RTN","SCMSVUT2",36,0) .Q "RTN","SCMSVUT2",37,0) Q "RTN","SCMSVUT2",38,0) ; "RTN","SCMSVUT2",39,0) VALWL(CLIN) ;WORKLOAD VALIDATION AT CHECK OUT "RTN","SCMSVUT2",40,0) ;INPUT CLIN - IEN OF CLINIC "RTN","SCMSVUT2",41,0) ;OUTPUT 0 - DO NOT VALIDATE WORKLOAD "RTN","SCMSVUT2",42,0) ; 1 - VALIDATE CLINIC WORKLOAD "RTN","SCMSVUT2",43,0) N A1 "RTN","SCMSVUT2",44,0) I '$D(CLIN) S CLIN=0 "RTN","SCMSVUT2",45,0) S A1=$P($G(^SC(+CLIN,0)),U,30) "RTN","SCMSVUT2",46,0) Q $S(A1=1:1,1:0) "RTN","SCMSVUT2",47,0) ; "RTN","SCMSVUT2",48,0) VALIDATE(XMITPTR) ;validates data that has a entry in the transmit file. "RTN","SCMSVUT2",49,0) ; "RTN","SCMSVUT2",50,0) ;INPUT XMITPTR - This is the point to an entry in file 409.73. "RTN","SCMSVUT2",51,0) ; "RTN","SCMSVUT2",52,0) ;OUTPUT -1 - the was a problem with the inputs "RTN","SCMSVUT2",53,0) ; 0 - no errors were found "RTN","SCMSVUT2",54,0) ; 1 - errors were found "RTN","SCMSVUT2",55,0) ; "RTN","SCMSVUT2",56,0) N VALERR,ERR,HL,HLEID,DFN "RTN","SCMSVUT2",57,0) S ANS=-1 "RTN","SCMSVUT2",58,0) S XMITPTR=+$G(XMITPTR) "RTN","SCMSVUT2",59,0) I $G(^SD(409.73,XMITPTR,0))']"" G VALQ "RTN","SCMSVUT2",60,0) D PATDFN^SCDXUTL2(XMITPTR) "RTN","SCMSVUT2",61,0) ; "RTN","SCMSVUT2",62,0) S HL7XMIT="^TMP(""HLS"","_$J_")",VALERR="^TMP(""SCDXVALID"","_$J_","_XMITPTR_")" "RTN","SCMSVUT2",63,0) ;Initialze HL7 variables "RTN","SCMSVUT2",64,0) S HLEID=+$O(^ORD(101,"B","SCDX AMBCARE SEND SERVER FOR ADT-Z00",0)) "RTN","SCMSVUT2",65,0) I ('HLEID) G VALQ "RTN","SCMSVUT2",66,0) D INIT^HLFNC2(HLEID,.HL) "RTN","SCMSVUT2",67,0) I ($O(HL(""))="") G VALQ "RTN","SCMSVUT2",68,0) ; "RTN","SCMSVUT2",69,0) S ERR=$$BUILDHL7^SCDXMSG0(XMITPTR,.HL,1,HL7XMIT,1,VALERR) "RTN","SCMSVUT2",70,0) ; "RTN","SCMSVUT2",71,0) I ERR<0,$O(@VALERR@(0))']"" D VALIDATE^SCMSVUT0("INTERNAL","","V900",VALERR,0) "RTN","SCMSVUT2",72,0) S ANS=0 "RTN","SCMSVUT2",73,0) D DELAERR^SCDXFU02(XMITPTR,0) "RTN","SCMSVUT2",74,0) D DEMUPDT(DFN,VALERR,"DEMO") "RTN","SCMSVUT2",75,0) I $O(@VALERR@(0))]"" DO "RTN","SCMSVUT2",76,0) .N FILE "RTN","SCMSVUT2",77,0) .S ANS=1 "RTN","SCMSVUT2",78,0) .S FILE=$$FILEVERR(XMITPTR,VALERR) "RTN","SCMSVUT2",79,0) .Q "RTN","SCMSVUT2",80,0) ; "RTN","SCMSVUT2",81,0) K @VALERR,@HL7XMIT "RTN","SCMSVUT2",82,0) ; "RTN","SCMSVUT2",83,0) VALQ Q ANS "RTN","SCMSVUT2",84,0) ; "RTN","SCMSVUT2",85,0) DEMUPDT(DFN,VALERR,TYP) ; "RTN","SCMSVUT2",86,0) ;This entry point updates all the other encoutners for this patient "RTN","SCMSVUT2",87,0) ;that HAVE errors with a new set or demographic errors or deletes all "RTN","SCMSVUT2",88,0) ;the demographic errors if none were found. "RTN","SCMSVUT2",89,0) ;INPUT DFN - The patient's DFN "RTN","SCMSVUT2",90,0) ; VALERR - errors to log "RTN","SCMSVUT2",91,0) ; TYP - The type of errors to delete and log. "RTN","SCMSVUT2",92,0) ; Right now demographic errors are the only kind "DEMO" "RTN","SCMSVUT2",93,0) ; "RTN","SCMSVUT2",94,0) S DFN=$G(DFN),TYP=$G(TYP),VALERR=$G(VALERR) "RTN","SCMSVUT2",95,0) I DFN=""!(TYP="")!(VALERR="") Q "RTN","SCMSVUT2",96,0) N PTRS,RNG,LP,PTR "RTN","SCMSVUT2",97,0) S RNG=$P($T(@(TYP)),";;",2),PTRS="" "RTN","SCMSVUT2",98,0) D CLEAN(DFN,RNG,.PTRS) "RTN","SCMSVUT2",99,0) I '$D(@VALERR@("PID")) Q "RTN","SCMSVUT2",100,0) I PTRS']"" Q "RTN","SCMSVUT2",101,0) F LP=1:1 S PTR=$P(PTRS,U,LP) Q:PTR']"" DO "RTN","SCMSVUT2",102,0) .I '$D(^SD(409.73,PTR,0)) Q "RTN","SCMSVUT2",103,0) .N FILE "RTN","SCMSVUT2",104,0) .D FILE(VALERR,"PID",PTR,.FILE) "RTN","SCMSVUT2",105,0) .Q "RTN","SCMSVUT2",106,0) Q "RTN","SCMSVUT2",107,0) ; "RTN","SCMSVUT2",108,0) CLEAN(DFN,RNG,PTRS) ;This subroutine cleans out all errors for a pateint "RTN","SCMSVUT2",109,0) ;and returns a string of which entries in 409.73 were cleaned of errors "RTN","SCMSVUT2",110,0) ; "RTN","SCMSVUT2",111,0) N LP,COD,LP2,IEN "RTN","SCMSVUT2",112,0) F LP=1:1 S COD=$P(RNG,U,LP) Q:COD']"" I $D(^SD(409.75,"ACOD",DFN,COD)) S IEN="" F LP2=1:1 S IEN=$O(^SD(409.75,"ACOD",DFN,COD,IEN)) Q:IEN']"" DO "RTN","SCMSVUT2",113,0) .N VAR,RES "RTN","SCMSVUT2",114,0) .S VAR=$P($G(^SD(409.75,IEN,0)),U,1)_"^" "RTN","SCMSVUT2",115,0) .I $P(VAR,U,1)="" S PTR="" Q "RTN","SCMSVUT2",116,0) .S RES=$$DELERR^SCDXFU02(IEN) "RTN","SCMSVUT2",117,0) .I PTRS[VAR Q "RTN","SCMSVUT2",118,0) .S PTRS=PTRS_VAR "RTN","SCMSVUT2",119,0) .Q "RTN","SCMSVUT2",120,0) Q "RTN","SCMSVUT2",121,0) ; "RTN","SCMSVUT2",122,0) MODCODE(DATA,ENCDT) ; "RTN","SCMSVUT2",123,0) ; "RTN","SCMSVUT2",124,0) ;--------------------------------------------------------------- "RTN","SCMSVUT2",125,0) ; VALIDATE MODIFIER AND CPT+MODIFIER COMBINATION "RTN","SCMSVUT2",126,0) ; "RTN","SCMSVUT2",127,0) ; INPUT: DATA - The procedure and modifier code to be checked "RTN","SCMSVUT2",128,0) ; format: CPT~modifier "RTN","SCMSVUT2",129,0) ; ENCDT - The date of the encounter "RTN","SCMSVUT2",130,0) ; "RTN","SCMSVUT2",131,0) ;OUTPUT: 1 - valid modifier and CPT+modifier combination "RTN","SCMSVUT2",132,0) ; 0 - invalid modifier or CPT+modifier combination "RTN","SCMSVUT2",133,0) ; "RTN","SCMSVUT2",134,0) ;**NOTE** This call makes the assumption that leading zeros are "RTN","SCMSVUT2",135,0) ; intact in the input. "RTN","SCMSVUT2",136,0) ;--------------------------------------------------------------- "RTN","SCMSVUT2",137,0) ; "RTN","SCMSVUT2",138,0) ;- validate modifier only "RTN","SCMSVUT2",139,0) N DATAMOD "RTN","SCMSVUT2",140,0) S DATAMOD=$P(DATA,"~",2) "RTN","SCMSVUT2",141,0) I '$D(DATAMOD) Q 0 "RTN","SCMSVUT2",142,0) I $$MOD^ICPTMOD(DATAMOD,"E",ENCDT,1)'>0 Q 0 "RTN","SCMSVUT2",143,0) ; "RTN","SCMSVUT2",144,0) ;- validate CPT+modifier pair "RTN","SCMSVUT2",145,0) N DATAPROC "RTN","SCMSVUT2",146,0) S DATAPROC=$P(DATA,"~",1) "RTN","SCMSVUT2",147,0) I '$D(DATAPROC) Q 0 "RTN","SCMSVUT2",148,0) I $$MODP^ICPTMOD(DATAPROC,DATAMOD,"E",ENCDT,1)'>0 Q 0 "RTN","SCMSVUT2",149,0) Q 1 "RTN","SCMSVUT2",150,0) ; "RTN","SCMSVUT2",151,0) MODMETH(DATA) ; "RTN","SCMSVUT2",152,0) ; "RTN","SCMSVUT2",153,0) ;--------------------------------------------------------------- "RTN","SCMSVUT2",154,0) ; VALIDATE MODIFIER CODING METHOD "RTN","SCMSVUT2",155,0) ; "RTN","SCMSVUT2",156,0) ; INPUT: DATA - The modifier coding method to be checked "RTN","SCMSVUT2",157,0) ; "RTN","SCMSVUT2",158,0) ;OUTPUT: 1 - valid modifier coding method "RTN","SCMSVUT2",159,0) ; 0 - invalid modifier coding method "RTN","SCMSVUT2",160,0) ; "RTN","SCMSVUT2",161,0) ; Valid modifier coding methods: C and H "RTN","SCMSVUT2",162,0) ;--------------------------------------------------------------- "RTN","SCMSVUT2",163,0) ; "RTN","SCMSVUT2",164,0) I '$D(DATA) Q 0 "RTN","SCMSVUT2",165,0) S DATA=","_DATA_"," "RTN","SCMSVUT2",166,0) I ",C,H,"'[DATA Q 0 "RTN","SCMSVUT2",167,0) Q 1 "RTN","SCMSVUT2",168,0) ; "RTN","SCMSVUT2",169,0) ETHNIC(DATA) ; "RTN","SCMSVUT2",170,0) ;INPUT DATA - the ethnicity code to be validated (NNNN-C-XXX) "RTN","SCMSVUT2",171,0) ; "RTN","SCMSVUT2",172,0) N VAL,MTHD "RTN","SCMSVUT2",173,0) I '$D(DATA) Q 0 "RTN","SCMSVUT2",174,0) I DATA="" Q 1 "RTN","SCMSVUT2",175,0) S VAL=$P(DATA,"-",1,2) "RTN","SCMSVUT2",176,0) S MTHD=$P(DATA,"-",3) "RTN","SCMSVUT2",177,0) I VAL'?4N1"-"1N Q 0 "RTN","SCMSVUT2",178,0) I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0 "RTN","SCMSVUT2",179,0) Q 1 "RTN","SCMSVUT2",180,0) ; "RTN","SCMSVUT2",181,0) DEMO ;;2000^2030^2050^2100^2150^2200^2210^2220^2230^2240^2250^2300^2330^2360 "RTN","SCMSVUT5") 0^8^B2983685 "RTN","SCMSVUT5",1,0) SCMSVUT5 ;BPFO/JRP - IEMM UTILTIES (CONT);7/29/2002 "RTN","SCMSVUT5",2,0) ;;5.3;Scheduling;**254**;Aug 13, 1993 "RTN","SCMSVUT5",3,0) SEGPRSE(SEGMENT,OUTARR,FS) ;Parse HL7 segment by field separator "RTN","SCMSVUT5",4,0) ;Input : SEGMENT - Array containing HL7 segment to parse (pass by ref) "RTN","SCMSVUT5",5,0) ; SEGMENT = First 245 characters of segment "RTN","SCMSVUT5",6,0) ; SEGMENT(1..n) = Continuation nodes "RTN","SCMSVUT5",7,0) ; OR "RTN","SCMSVUT5",8,0) ; SEGMENT(x) = First 245 characters of segment "RTN","SCMSVUT5",9,0) ; SEGMENT(x,1..n) = Continuation nodes "RTN","SCMSVUT5",10,0) ; OUTARR - Array to put parsed segment into (full global ref) "RTN","SCMSVUT5",11,0) ; FS - HL7 field separator (defaults to ^) (1 character) "RTN","SCMSVUT5",12,0) ;Output : None "RTN","SCMSVUT5",13,0) ; OUTARR(0) = Segment name "RTN","SCMSVUT5",14,0) ; OUTARR(seq#) = Data "RTN","SCMSVUT5",15,0) ;Notes : OUTARR is initialized (KILLed) on entry "RTN","SCMSVUT5",16,0) ; : Assumes no sequence is longer than 245 characters "RTN","SCMSVUT5",17,0) ; "RTN","SCMSVUT5",18,0) ;Declare variables "RTN","SCMSVUT5",19,0) N SEQ,NODE,STOP,DATA,INFO,I,L "RTN","SCMSVUT5",20,0) K @OUTARR "RTN","SCMSVUT5",21,0) S FS=$G(FS,"^") S FS=$E(FS,1) S:FS="" FS="^" "RTN","SCMSVUT5",22,0) S SEQ=0 "RTN","SCMSVUT5",23,0) S NODE=$NA(SEGMENT) "RTN","SCMSVUT5",24,0) S INFO=$G(@NODE) "RTN","SCMSVUT5",25,0) S I=1 "RTN","SCMSVUT5",26,0) S L=$L(INFO,FS) "RTN","SCMSVUT5",27,0) S STOP=0 "RTN","SCMSVUT5",28,0) F S DATA=$P(INFO,FS,I) D Q:STOP "RTN","SCMSVUT5",29,0) .I I=L D Q "RTN","SCMSVUT5",30,0) ..S @OUTARR@(SEQ)=$G(@OUTARR@(SEQ))_DATA "RTN","SCMSVUT5",31,0) ..S NODE=$Q(@NODE) "RTN","SCMSVUT5",32,0) ..I NODE="" S STOP=1 Q "RTN","SCMSVUT5",33,0) ..S INFO=$G(@NODE) "RTN","SCMSVUT5",34,0) ..S L=$L(INFO,FS) "RTN","SCMSVUT5",35,0) ..S I=1 "RTN","SCMSVUT5",36,0) .S @OUTARR@(SEQ)=$G(@OUTARR@(SEQ))_DATA "RTN","SCMSVUT5",37,0) .S SEQ=SEQ+1 "RTN","SCMSVUT5",38,0) .S I=I+1 "RTN","SCMSVUT5",39,0) Q "RTN","SCMSVUT5",40,0) ; "RTN","SCMSVUT5",41,0) SEQPRSE(SEQDATA,OUTARR,ENCODE) ;Parse HL7 sequence by component "RTN","SCMSVUT5",42,0) ;Input : SEQDATA - Sequence (field) to parse "RTN","SCMSVUT5",43,0) ; OUTARR - Array to put parsed sequence into (full global ref) "RTN","SCMSVUT5",44,0) ; ENCODE - HL7 encoding characters (defaults to ~|\&) (4 chars) "RTN","SCMSVUT5",45,0) ;Output : None "RTN","SCMSVUT5",46,0) ; OUTARR(rep#,comp#) "RTN","SCMSVUT5",47,0) ;Notes : OUTARR is initialized (KILLed) on entry "RTN","SCMSVUT5",48,0) ; "RTN","SCMSVUT5",49,0) ;Declare variables "RTN","SCMSVUT5",50,0) N RS,CS,INFO,DATA,REP,COMP "RTN","SCMSVUT5",51,0) K @OUTARR "RTN","SCMSVUT5",52,0) S ENCODE=$G(ENCODE,"~|\&") "RTN","SCMSVUT5",53,0) S ENCODE=$E(ENCODE,1,4) S:$L(ENCODE)'=4 ENCODE="~|\&" "RTN","SCMSVUT5",54,0) S CS=$E(ENCODE,1) "RTN","SCMSVUT5",55,0) S RS=$E(ENCODE,2) "RTN","SCMSVUT5",56,0) F REP=1:1:$L(SEQDATA,RS) S INFO=$P(SEQDATA,RS,REP) D "RTN","SCMSVUT5",57,0) .F COMP=1:1:$L(INFO,CS) S @OUTARR@(REP,COMP)=$P(INFO,CS,COMP) "RTN","SCMSVUT5",58,0) Q "RTN","SCRPW24") 0^2^B73184734 "RTN","SCRPW24",1,0) SCRPW24 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;06/19/99 "RTN","SCRPW24",2,0) ;;5.3;Scheduling;**144,163,180,254**;AUG 13, 1993 "RTN","SCRPW24",3,0) ;06/19/99 ACS - Added CPT modifier API calls "RTN","SCRPW24",4,0) ; "RTN","SCRPW24",5,0) APAC(SDX) ;Get all procedure codes "RTN","SCRPW24",6,0) ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U)_U_$P(SDY(SDI),U,16) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX "RTN","SCRPW24",7,0) D APAC^SCRPW241(.SDX) "RTN","SCRPW24",8,0) D NX Q "RTN","SCRPW24",9,0) ; "RTN","SCRPW24",10,0) APOTR ;Transform procedure external value "RTN","SCRPW24",11,0) ;S $P(SDX,U,2)=$P(SDX,U,2)_" "_$P(^ICPT(+SDX,0),U,2) Q "RTN","SCRPW24",12,0) D APOTR^SCRPW241(.SDX) "RTN","SCRPW24",13,0) Q "RTN","SCRPW24",14,0) ; "RTN","SCRPW24",15,0) APAP(SDX) ;Get ambulatory procedures (no E&M codes) "RTN","SCRPW24",16,0) ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I '$D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX "RTN","SCRPW24",17,0) D APAP^SCRPW241(.SDX) "RTN","SCRPW24",18,0) D NX Q "RTN","SCRPW24",19,0) ; "RTN","SCRPW24",20,0) APEM(SDX) ;Get evaluation and management codes "RTN","SCRPW24",21,0) ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I $D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX "RTN","SCRPW24",22,0) D APEM^SCRPW241(.SDX) "RTN","SCRPW24",23,0) D NX Q "RTN","SCRPW24",24,0) ; "RTN","SCRPW24",25,0) CLCG(SDX) ;Get clinic group "RTN","SCRPW24",26,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 SDX=SDX_U_$P(^SD(409.67,SDX,0),U) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",27,0) D NX Q "RTN","SCRPW24",28,0) ; "RTN","SCRPW24",29,0) CLCN(SDX) ;Get clinic name "RTN","SCRPW24",30,0) K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=SDX_U_$P($G(^SC(SDX,0)),U) I $L($P(SDX,U,2)) S SDX(1)=SDX "RTN","SCRPW24",31,0) D NX Q "RTN","SCRPW24",32,0) ; "RTN","SCRPW24",33,0) CLCS(SDX) ;Get clinic service "RTN","SCRPW24",34,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",35,0) D NX Q "RTN","SCRPW24",36,0) ; "RTN","SCRPW24",37,0) DXAD(SDX) ;Get all diagnoses "RTN","SCRPW24",38,0) K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U) I SDX S SDX=SDX_U_$P($G(^ICD9(+SDX,0)),U) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX "RTN","SCRPW24",39,0) D NX Q "RTN","SCRPW24",40,0) ; "RTN","SCRPW24",41,0) DXOTR ;Transform diagnosis external value "RTN","SCRPW24",42,0) S SDX=SDX_" "_$P(^ICD9(+SDX,0),U,3) Q "RTN","SCRPW24",43,0) ; "RTN","SCRPW24",44,0) DXGS(SDX,SDZ) ;Get GAF score "RTN","SCRPW24",45,0) K SDX N SDI,SDY S SDY=$S(SDZ="H":$P($P(SDOE0,U),"."),1:DT)_.9999,SDY=9999999-SDY,SDY=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY)) "RTN","SCRPW24",46,0) I SDY S SDI=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY,""),-1) I SDI S SDX=+$P($G(^YSD(627.8,SDI,60)),U,3) I SDX S SDX(1)=SDX_U_SDX "RTN","SCRPW24",47,0) D NX Q "RTN","SCRPW24",48,0) ; "RTN","SCRPW24",49,0) DXGSQ(SDI) ;Set up GAF help text "RTN","SCRPW24",50,0) S SDIRQ("?",1)="Specify a value representing the Global Assessment of Functioning (GAF) score." "RTN","SCRPW24",51,0) I SDI="H" S SDIRQ("?")="Status as of the encounter date/time is used to determine 'historical' values." "RTN","SCRPW24",52,0) I SDI="C" S SDIRQ("?")="Status as of the report run date is used to determine 'current' values." "RTN","SCRPW24",53,0) Q "RTN","SCRPW24",54,0) ; "RTN","SCRPW24",55,0) DXPD(SDX) ;Get primary diagnosis "RTN","SCRPW24",56,0) K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=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($G(^ICD9(+SDX,0)),U) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX Q "RTN","SCRPW24",57,0) D NX Q "RTN","SCRPW24",58,0) ; "RTN","SCRPW24",59,0) DXSD(SDX) ;Get secondary diagnoses "RTN","SCRPW24",60,0) K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=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($G(^ICD9(+SDX,0)),U) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX "RTN","SCRPW24",61,0) D NX Q "RTN","SCRPW24",62,0) ; "RTN","SCRPW24",63,0) ENED(SDX,SDZ) ;Get enrollment date "RTN","SCRPW24",64,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 "RTN","SCRPW24",65,0) D NX Q "RTN","SCRPW24",66,0) ; "RTN","SCRPW24",67,0) ENEF(SDX,SDZ) ;Get enrollment effective date "RTN","SCRPW24",68,0) K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U,8) X ^DD("DD") S SDX(1)=SDX_U_Y "RTN","SCRPW24",69,0) D NX Q "RTN","SCRPW24",70,0) ; "RTN","SCRPW24",71,0) ENEP(SDX,SDZ) ;Get enrollment priority "RTN","SCRPW24",72,0) K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,7) D FST(.SDX,27.11,.07) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",73,0) D NX Q "RTN","SCRPW24",74,0) ; "RTN","SCRPW24",75,0) ENES(SDX,SDZ) ;Get enrollment status "RTN","SCRPW24",76,0) K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,4) D FST(.SDX,27.11,.04) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",77,0) D NX Q "RTN","SCRPW24",78,0) ; "RTN","SCRPW24",79,0) ENFR(SDX,SDZ) ;Get enrollment facility received "RTN","SCRPW24",80,0) K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,6) I SDX S SDX=SDX_U_$P($G(^DIC(4,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",81,0) D NX Q "RTN","SCRPW24",82,0) ; "RTN","SCRPW24",83,0) ENSE(SDX,SDZ) ;Get enrollment source of enrollment "RTN","SCRPW24",84,0) K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,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",85,0) D NX Q "RTN","SCRPW24",86,0) ; "RTN","SCRPW24",87,0) ENQ(SDZ) ;Set up help text for enrollment "RTN","SCRPW24",88,0) I SDZ="H" S SDIRQ("?")="Enrollment status as of the encounter date/time is used for 'historical' values." "RTN","SCRPW24",89,0) I SDZ="C" S SDIRQ("?")="Enrollment status as of the report run date is used for 'current' values." "RTN","SCRPW24",90,0) Q "RTN","SCRPW24",91,0) ; "RTN","SCRPW24",92,0) OEAT(SDX) ;Get encounter appointment type "RTN","SCRPW24",93,0) K SDX S SDX=$P(SDOE0,U,10) I SDX S SDX=SDX_U_$P($G(^SD(409.1,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",94,0) D NX Q "RTN","SCRPW24",95,0) ; "RTN","SCRPW24",96,0) OEDV(SDX) ;Get encounter division "RTN","SCRPW24",97,0) K SDX S SDX=$P(SDOE0,U,11) I SDX S SDX=SDX_U_$P($G(^DG(40.8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",98,0) D NX Q "RTN","SCRPW24",99,0) ; "RTN","SCRPW24",100,0) OEEE(SDX) ;Get encounter eligibility "RTN","SCRPW24",101,0) K SDX S SDX=$P(SDOE0,U,13) I SDX S SDX=SDX_U_$P($G(^DIC(8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",102,0) D NX Q "RTN","SCRPW24",103,0) ; "RTN","SCRPW24",104,0) OEOP(SDX) ;Get encounter originating process type "RTN","SCRPW24",105,0) K SDX S SDX=$P(SDOE0,U,8) D FST(.SDX,409.68,.08) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",106,0) D NX Q "RTN","SCRPW24",107,0) ; "RTN","SCRPW24",108,0) OEPA(SDX) ;Get encounter patient "RTN","SCRPW24",109,0) K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L(VADM(1)) S SDX(1)=DFN_U_VADM(1) "RTN","SCRPW24",110,0) D NX Q "RTN","SCRPW24",111,0) ; "RTN","SCRPW24",112,0) OEES(SDX) ;Get encounter status "RTN","SCRPW24",113,0) K SDX S SDX=$P(SDOE0,U,12) I SDX S SDX=SDX_U_$P($G(^SD(409.63,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",114,0) D NX Q "RTN","SCRPW24",115,0) ; "RTN","SCRPW24",116,0) OETS(SDX) ;Get transmission status "RTN","SCRPW24",117,0) K SDX S SDX(1)=$$STX^SCRPW8(SDOE,SDOE0) Q "RTN","SCRPW24",118,0) ; "RTN","SCRPW24",119,0) TSQ(DIR) ;Set up DIR array for transmission status question "RTN","SCRPW24",120,0) K DIR S DIR("A")="Select transmission status",DIR("?")="This value represents the transmission status of the encounter record." "RTN","SCRPW24",121,0) S DIR(0)="SO^0:Not checked-out;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted" "RTN","SCRPW24",122,0) Q "RTN","SCRPW24",123,0) ; "RTN","SCRPW24",124,0) CLQ(DIR,SDZ) ;Set up DIR array for classification questions "RTN","SCRPW24",125,0) K DIR S SDZ=$S(SDZ="A":"Agent Orange exposure",SDZ="I":"ionizing radiation exposure",SDZ="S":"service connected condition",1:"environmental contaminants exposure") "RTN","SCRPW24",126,0) S DIR(0)="SO^1:YES;0:NO",DIR("A")="Treatment related to "_SDZ,DIR("?")="Indicates if treatment was related to "_SDZ Q "RTN","SCRPW24",127,0) ; "RTN","SCRPW24",128,0) OECL(SDX,SDZ) ;Get classification values "RTN","SCRPW24",129,0) K SDX N SDY S SDZ=$S(SDZ="A":1,SDZ="I":2,SDZ="S":3,SDZ="E":4,1:"") I SDZ D CLASK^SDCO2(SDOE,.SDY) S SDX=$P($G(SDY(SDZ)),U,2) I $L(SDX) S SDX(1)=$S(SDX=1:"1^YES",1:"0^NO") "RTN","SCRPW24",130,0) D NX Q "RTN","SCRPW24",131,0) ; "RTN","SCRPW24",132,0) OEOU(SDX) ;Get option used to create "RTN","SCRPW24",133,0) K SDX S SDX=+$P(SDOE0,U,5),SDX=+$P($G(^AUPNVSIT(SDX,0)),U,24) "RTN","SCRPW24",134,0) N SDY D GETS^DIQ(19,SDX,.01,"","SDY") "RTN","SCRPW24",135,0) S SDX=SDX_U_SDY(19,SDX_",",.01) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",136,0) D NX Q "RTN","SCRPW24",137,0) ; "RTN","SCRPW24",138,0) SUQ(DIR) ;Set up DIR() array for Scheduled/unscheduled question "RTN","SCRPW24",139,0) K DIR S DIR("A")="Select outpatient activity type",DIR("?",1)="Only pre-scheduled appointments will be reflected as SCHEDULED. All other",DIR("?",2)="types of activity (add/edits, registrations, walkins or unscheduled activity)" "RTN","SCRPW24",140,0) S DIR("?")="will be reflected as UNSCHEDULED.",DIR(0)="SO^S:SCHEDULED;U:UNSCHEDULED" Q "RTN","SCRPW24",141,0) ; "RTN","SCRPW24",142,0) OESU(SDX) ;Get scheduled/unscheduled status "RTN","SCRPW24",143,0) N SDAP0 K SDX S SDX(1)="" "RTN","SCRPW24",144,0) I $P(SDOE0,U,8)=1 D Q:$L(SDX(1)) "RTN","SCRPW24",145,0) .S SDAP0=$G(^DPT(+$P(SDOE0,U,2),"S",+SDOE0,0)) "RTN","SCRPW24",146,0) .Q:$P(SDAP0,U,20)'=SDOE Q:$P(SDAP0,U,7)=4 "RTN","SCRPW24",147,0) .S SDX(1)="S^SCHEDULED" Q "RTN","SCRPW24",148,0) S SDX(1)="U^UNSCHEDULED" Q "RTN","SCRPW24",149,0) ; "RTN","SCRPW24",150,0) PCPR(SDX,SDZ) ;Get primary care provider "RTN","SCRPW24",151,0) ;Required input: SDZ="C" for current, "H" for historical "RTN","SCRPW24",152,0) K SDX S SDX=$S(SDZ="C":$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",153,0) D NX Q "RTN","SCRPW24",154,0) ; "RTN","SCRPW24",155,0) PCTM(SDX,SDZ) ;Get priamry care team "RTN","SCRPW24",156,0) ;Required input: SDZ="C" for current, "H" for historical "RTN","SCRPW24",157,0) K SDX S SDX=$S(SDZ="C":$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX "RTN","SCRPW24",158,0) D NX Q "RTN","SCRPW24",159,0) ; "RTN","SCRPW24",160,0) PDPA(SDX) ;Get patient age "RTN","SCRPW24",161,0) K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I VADM(4)=+VADM(4) S SDX(1)=VADM(4)_U_VADM(4) "RTN","SCRPW24",162,0) D NX Q "RTN","SCRPW24",163,0) ; "RTN","SCRPW24",164,0) PDPS(SDX) ;Get patient sex "RTN","SCRPW24",165,0) K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L($P(VADM(5),U,2)) S SDX(1)=VADM(5) "RTN","SCRPW24",166,0) D NX Q "RTN","SCRPW24",167,0) ; "RTN","SCRPW24",168,0) PDSC(SDX) ;Get patient state/county "RTN","SCRPW24",169,0) K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L($P(VAPA(7),U,2)) S SDX(1)=$P(VAPA(5),U)_";"_$P(VAPA(7),U)_U_$P(VAPA(5),U,2)_" / "_$P(VAPA(7),U,2) "RTN","SCRPW24",170,0) D NX Q "RTN","SCRPW24",171,0) ; "RTN","SCRPW24",172,0) PDZC(SDX) ;Get patient zip code "RTN","SCRPW24",173,0) K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L(VAPA(6)) S SDX(1)=VAPA(6)_U_VAPA(6) "RTN","SCRPW24",174,0) D NX Q "RTN","SCRPW24",175,0) ; "RTN","SCRPW24",176,0) ENROL(SDATE) ;Get enrollment record (most recent to encounter date but not more than one year prior) "RTN","SCRPW24",177,0) N SDY,SDI,X1,X2,X,%Y S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI S SDY=$G(^DGEN(27.11,SDI,0)),SDY(+SDY)=SDY "RTN","SCRPW24",178,0) S SDI=$O(SDY(SDATE),-1) Q:'SDI "" S X1=$P($P(SDOE0,U),"."),X2=SDI D ^%DTC Q:X>366 "" Q SDY(SDI) "RTN","SCRPW24",179,0) ; "RTN","SCRPW24",180,0) NX S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~NONE~~~" Q "RTN","SCRPW24",181,0) ; "RTN","SCRPW24",182,0) FST(SDX,SDFI,SDFE) ;Field set transform "RTN","SCRPW24",183,0) Q:'$L(SDX) N SDY,SDI D FIELD^DID(SDFI,SDFE,"","POINTER","SDY") S SDY=SDY("POINTER") F SDI=1:1:$L(SDY,";") I SDX=$P($P(SDY,";",SDI),":") S SDX=SDX_U_$P($P(SDY,";",SDI),":",2) Q "RTN","SCRPW24",184,0) Q "RTN","SCRPW241") 0^3^B11894412 "RTN","SCRPW241",1,0) SCRPW241 ;BPCIOFO/ACS - ACRP Ad Hoc Report (cont.) ;06/30/99 "RTN","SCRPW241",2,0) ;;5.3;Scheduling;**180,254**;AUG 13, 1993 "RTN","SCRPW241",3,0) ; "RTN","SCRPW241",4,0) ;---------------------------------------------------------------- "RTN","SCRPW241",5,0) ; This routine was created due to the max number of bytes "RTN","SCRPW241",6,0) ; being reached in SCRPW24 "RTN","SCRPW241",7,0) ; "RTN","SCRPW241",8,0) ; This routine is called by SCRPW24, and it contains CPT API calls "RTN","SCRPW241",9,0) ; "RTN","SCRPW241",10,0) ;---------------------------------------------------------------- "RTN","SCRPW241",11,0) ; "RTN","SCRPW241",12,0) APAC(SDX) ;Get all procedure codes "RTN","SCRPW241",13,0) ; INPUT - .SDX array reference "RTN","SCRPW241",14,0) ; OUTPUT- SDX array with CPT pointer, CPT code, quantity "RTN","SCRPW241",15,0) ; "RTN","SCRPW241",16,0) K SDX "RTN","SCRPW241",17,0) N SDY,SDI,CPTINFO,CPTCODE "RTN","SCRPW241",18,0) ; array SDY will contain the CPT information "RTN","SCRPW241",19,0) D GETCPT^SDOE(SDOE,"SDY") "RTN","SCRPW241",20,0) ; "RTN","SCRPW241",21,0) ; Spin through CPT array and get CPT code and quantity "RTN","SCRPW241",22,0) S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D "RTN","SCRPW241",23,0) . I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U) "RTN","SCRPW241",24,0) . E Q "RTN","SCRPW241",25,0) . S CPTINFO=$$CPT^ICPTCOD(+SDX,,1) "RTN","SCRPW241",26,0) . Q:CPTINFO'>0 "RTN","SCRPW241",27,0) . S CPTCODE=$P(CPTINFO,U,2) "RTN","SCRPW241",28,0) . S SDX=SDX_U_CPTCODE_U_$P(SDY(SDI,0),U,16) "RTN","SCRPW241",29,0) . I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX "RTN","SCRPW241",30,0) . Q "RTN","SCRPW241",31,0) Q "RTN","SCRPW241",32,0) ; "RTN","SCRPW241",33,0) APOTR(SDX) ;Transform procedure external value "RTN","SCRPW241",34,0) ; INPUT - .SDX CPT pointer "RTN","SCRPW241",35,0) ; OUTPUT- SDX text string containing CPT code, CPT text "RTN","SCRPW241",36,0) ; "RTN","SCRPW241",37,0) N CPTINFO,CPTTEXT "RTN","SCRPW241",38,0) S CPTINFO=$$CPT^ICPTCOD(+SDX,,1) "RTN","SCRPW241",39,0) Q:CPTINFO'>0 "RTN","SCRPW241",40,0) S CPTTEXT=$P(CPTINFO,U,3) "RTN","SCRPW241",41,0) S $P(SDX,U,2)=$P(SDX,U,2)_" "_CPTTEXT "RTN","SCRPW241",42,0) Q "RTN","SCRPW241",43,0) ; "RTN","SCRPW241",44,0) APAP(SDX) ;Get ambulatory procedures (no E&M codes) "RTN","SCRPW241",45,0) ; INPUT - .SDX array reference "RTN","SCRPW241",46,0) ; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text "RTN","SCRPW241",47,0) ; "RTN","SCRPW241",48,0) K SDX "RTN","SCRPW241",49,0) N SDY,SDI,CPTINFO,CPTCODE "RTN","SCRPW241",50,0) D GETCPT^SDOE(SDOE,"SDY") "RTN","SCRPW241",51,0) ; Spin through CPT array and get CPT code "RTN","SCRPW241",52,0) S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D "RTN","SCRPW241",53,0) . I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U) "RTN","SCRPW241",54,0) . E Q "RTN","SCRPW241",55,0) . I '$D(^IBE(357.69,"B",SDX)) D "RTN","SCRPW241",56,0) .. S CPTINFO=$$CPT^ICPTCOD(+SDX,,1) "RTN","SCRPW241",57,0) .. Q:CPTINFO'>0 "RTN","SCRPW241",58,0) .. S CPTCODE=$P(CPTINFO,U,2) "RTN","SCRPW241",59,0) .. S SDX=SDX_U_CPTCODE "RTN","SCRPW241",60,0) .. I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX "RTN","SCRPW241",61,0) .. Q "RTN","SCRPW241",62,0) . Q "RTN","SCRPW241",63,0) Q "RTN","SCRPW241",64,0) ; "RTN","SCRPW241",65,0) APEM(SDX) ;Get evaluation and management codes "RTN","SCRPW241",66,0) ; INPUT - .SDX array reference "RTN","SCRPW241",67,0) ; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text "RTN","SCRPW241",68,0) ; "RTN","SCRPW241",69,0) K SDX "RTN","SCRPW241",70,0) N SDY,SDI,CPTINFO,CPTCODE "RTN","SCRPW241",71,0) D GETCPT^SDOE(SDOE,"SDY") "RTN","SCRPW241",72,0) ; "RTN","SCRPW241",73,0) ; Spin through CPT array and get CPT code "RTN","SCRPW241",74,0) S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D "RTN","SCRPW241",75,0) . I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U) "RTN","SCRPW241",76,0) . E Q "RTN","SCRPW241",77,0) . I $D(^IBE(357.69,"B",SDX)) D "RTN","SCRPW241",78,0) .. S CPTINFO=$$CPT^ICPTCOD(+SDX,,1) "RTN","SCRPW241",79,0) .. Q:CPTINFO'>0 "RTN","SCRPW241",80,0) .. S CPTCODE=$P(CPTINFO,U,2) "RTN","SCRPW241",81,0) .. S SDX=SDX_U_CPTCODE "RTN","SCRPW241",82,0) .. I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX "RTN","SCRPW241",83,0) .. Q "RTN","SCRPW241",84,0) . Q "RTN","SCRPW241",85,0) Q "RTN","SCRPW241",86,0) ; "RTN","SCRPW241",87,0) PDPE(SDX) ;Get patient's ethnicities "RTN","SCRPW241",88,0) K SDX "RTN","SCRPW241",89,0) N DFN,VADM,NUM,CNT,ABB,TXT "RTN","SCRPW241",90,0) S DFN=$P(SDOE0,U,2) "RTN","SCRPW241",91,0) I DFN D DEM^VADPT I VADM(11) S CNT=1,NUM=0 F S NUM=+$O(VADM(11,NUM)) Q:'NUM D "RTN","SCRPW241",92,0) .I VADM(11,NUM) D "RTN","SCRPW241",93,0) ..S TXT=$$PTR2TEXT^DGUTL4(+VADM(11,NUM),2) S:TXT="" TXT="?" "RTN","SCRPW241",94,0) ..S ABB=$$PTR2CODE^DGUTL4(+$G(VADM(11,NUM,1)),3,1) S:ABB="" ABB="?" "RTN","SCRPW241",95,0) ..S SDX(CNT)=+VADM(11,NUM)_"^"_TXT_" ("_ABB_")",CNT=CNT+1 "RTN","SCRPW241",96,0) S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~" "RTN","SCRPW241",97,0) Q "RTN","SCRPW241",98,0) ; "RTN","SCRPW241",99,0) PDPR(SDX) ;Get patient's race "RTN","SCRPW241",100,0) K SDX "RTN","SCRPW241",101,0) N DFN,VADM,NUM,CNT,ABB,TXT "RTN","SCRPW241",102,0) S DFN=$P(SDOE0,U,2) "RTN","SCRPW241",103,0) I DFN D DEM^VADPT I VADM(12) S CNT=1,NUM=0 F S NUM=+$O(VADM(12,NUM)) Q:'NUM D "RTN","SCRPW241",104,0) .I VADM(12,NUM) D "RTN","SCRPW241",105,0) ..S TXT=$$PTR2TEXT^DGUTL4(+VADM(12,NUM),1) S:TXT="" TXT="?" "RTN","SCRPW241",106,0) ..S ABB=$$PTR2CODE^DGUTL4(+$G(VADM(12,NUM,1)),3,1) S:ABB="" ABB="?" "RTN","SCRPW241",107,0) ..S SDX(CNT)=+VADM(12,NUM)_"^"_TXT_" ("_ABB_")",CNT=CNT+1 "RTN","SCRPW241",108,0) S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~" "RTN","SCRPW241",109,0) Q "RTN","SDM") 0^1^B26612047 "RTN","SDM",1,0) SDM ;SF/GFT,ALB/BOK - MAKE AN APPOINTMENT ; 08 Nov 2000 2:26 PM "RTN","SDM",2,0) ;;5.3;Scheduling;**15,32,38,41,44,79,94,167,168,218,223,250,254**;AUG 13, 1993 "RTN","SDM",3,0) ; If defined... "RTN","SDM",4,0) ; appt mgt vars: SDFN := DFN of patient....will not be asked "RTN","SDM",5,0) ; SDCLN := ifn of clinic.....will not be asked "RTN","SDM",6,0) ; SDAMERR := returned if error occurs "RTN","SDM",7,0) ; "RTN","SDM",8,0) S:'$D(SDMM) SDMM=0 "RTN","SDM",9,0) EN1 L W !! D I^SDUTL I '$D(SDCLN) S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))" D ^DIC K DIC G:Y<0!'$D(^("SL")) END "RTN","SDM",10,0) K SDAPTYP,SDIN,SDRE,SDXXX S:$D(SDCLN) Y=+SDCLN "RTN","SDM",11,0) I $D(^SC(+Y,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),U,2) "RTN","SDM",12,0) K SDINA I $D(SDIN),SDIN S SDINA=SDIN K SDIN "RTN","SDM",13,0) I $D(SD),$D(SC),+Y'=+SC K SD "RTN","SDM",14,0) S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y "RTN","SDM",15,0) I $D(^SC(+SC,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(+SC,"SDPRIV",DUZ)) W !,*7,"Access to ",$$CNAM(+SC)," is prohibited!",!,"Only users with a special code may access this clinic.",*7 S:$D(SDCLN) SDAMERR="" G END:$D(SDCLN),SDM "RTN","SDM",16,0) D CS^SDM1A S SDW="",WY="Y" "RTN","SDM",17,0) I '$D(ORACTION),'$D(SDFN) S (DIC,DIE)="^DPT(",DIC(0)="AQZME" D ^DIC S DFN=+Y G:Y<0 END:$D(SDCLN),^SDM0:X[U,SDM "RTN","SDM",18,0) S:$D(SDFN) DFN=SDFN "RTN","SDM",19,0) I $D(^DPT(DFN,.35)),$P(^(.35),U)]"" W !?10,*7,"PATIENT HAS DIED." S:$D(SDFN) SDAMERR="" G END:$D(SDFN),SDM "RTN","SDM",20,0) D ^SDM4 I $S('$D(COLLAT):1,COLLAT=7:1,1:0) G:$D(SDCLN) END G SDM "RTN","SDM",21,0) ;-- get sub-category for appointment type "RTN","SDM",22,0) S SDXSCAT=$$SUB^DGSAUTL(SDAPTYP,2,"") "RTN","SDM",23,0) K SDXXX D EN G END:$D(SDCLN),SDM "RTN","SDM",24,0) EN K SDMLT1 W:$P(VAEL(9),U,2)]"" !!,?15,"MEANS TEST STATUS: ",$P(VAEL(9),U,2),! "RTN","SDM",25,0) ; *** sck, mt blocking "RTN","SDM",26,0) S X="EASMTCHK" X ^%ZOSF("TEST") I $T,$$MT^EASMTCHK(DFN,+$G(SDAPTYP),"M") S SDAMERR="" Q "RTN","SDM",27,0) S Y=DFN,Y(0)=^DPT(DFN,0) I VADM(7)]"" W !?3,*7,VADM(7) "RTN","SDM",28,0) I $D(^DGS(41.1,"B",DFN)) F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) Q:I'>0 I $P(^DGS(41.1,I,0),U,2)'DT !,"NO PENDING APPOINTMENTS" "RTN","SDM",30,0) I $O(^DPT(DFN,"S",DT))>DT D G END:%<0,HELP:'% "RTN","SDM",31,0) .S %=2 W !,"DISPLAY PENDING APPOINTMENTS:" "RTN","SDM",32,0) .D YN^DICN "RTN","SDM",33,0) .I %Y["^" S SDMLT1=1 "RTN","SDM",34,0) D:%=1 "RTN","SDM",35,0) .N DX,DY,SDXY,SDEND S SDXY="S DX=$X,DY=0"_$S($L($G(^%ZOSF("XY"))):" "_^("XY"),1:"") X SDXY "RTN","SDM",36,0) .F Y=DT:0 S Y=$O(^DPT(DFN,"S",Y)) Q:Y'>0 I "I"[$P(^(Y,0),U,2) X:(($Y+4)>IOSL) "D OUT^SDUTL X SDXY" Q:$G(SDEND) D CHKSO W:$X>9 ! W ?11 D DT^SDM0 W ?32 S DA=+SSC W SDLN,$S($D(^SC(DA,0)):$P(^(0),U),1:"DELETED CLINIC "),COV," ",SDAT16 "RTN","SDM",37,0) ;Prompt for ETHNICITY if no value on file "RTN","SDM",38,0) I '$O(^DPT(DFN,.06,0)) D "RTN","SDM",39,0) .S DA=DFN,DR="6ETHNICITY",DIE="^DPT(" "RTN","SDM",40,0) .S DR(2,2.06)=".01ETHNICITY" "RTN","SDM",41,0) .D ^DIE K DR "RTN","SDM",42,0) ;Prompt for RACE if no value on file "RTN","SDM",43,0) I '$O(^DPT(DFN,.02,0)) D "RTN","SDM",44,0) .S DA=DFN,DR="2RACE",DIE="^DPT(" "RTN","SDM",45,0) .S DR(2,2.02)=".01RACE" "RTN","SDM",46,0) .D ^DIE K DR "RTN","SDM",47,0) S DA=DFN,DR=$S('$D(^DPT(DA,.11)):"[SDM1]",$P(^(.11),U)="":"[SDM1]",1:"") "RTN","SDM",48,0) S DIE="^DPT(" D ^DIE:DR]"" K DR Q:$D(SDXXX) "RTN","SDM",49,0) E S Y=$P(SL,U,5) "RTN","SDM",50,0) S SDW="" I $D(^DPT(DFN,.1)) S SDW=^(.1) W !,"NOTE - PATIENT IS NOW IN WARD "_SDW "RTN","SDM",51,0) Q:$D(SDXXX) "RTN","SDM",52,0) EN2 F X=0:0 S X=$O(^DPT(DFN,"DE",X)) Q:'$D(^(+X,0)) I ^(0)-SC=0!'(^(0)-Y) F XX=0:0 S XX=$O(^DPT(DFN,"DE",X,1,XX)) Q:XX<1 S SDDIS=$P(^(XX,0),U,3) G ^SDM0:'SDDIS "RTN","SDM",53,0) I '$D(^SC(+Y,0)) S Y=+SC "RTN","SDM",54,0) S Y=$P(^SC(Y,0),U) "RTN","SDM",55,0) ; SCRESTA = Array of pt's teams causing restricted consults "RTN","SDM",56,0) N SCRESTA "RTN","SDM",57,0) S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") "RTN","SDM",58,0) IF SCREST D "RTN","SDM",59,0) .N SCTM "RTN","SDM",60,0) . S SCCLNM=Y "RTN","SDM",61,0) . W !,?5,"Patient has restricted consults due to team assignment(s):" "RTN","SDM",62,0) .S SCTM=0 "RTN","SDM",63,0) .F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) "RTN","SDM",64,0) IF SCREST&'$G(SCOKCONS) D Q "RTN","SDM",65,0) .W !,?5,"This patient may only be given appointments and enrolled in clinics via" "RTN","SDM",66,0) .W !,?15,"Make Consult Appointment Option, and" "RTN","SDM",67,0) .W !,?15,"Edit Clinic Enrollment Data option" "RTN","SDM",68,0) D:$G(SCREST) MAIL^SCMCCON(DFN,.SCCLNM,2,DT,"SCRESTA") "RTN","SDM",69,0) K DR,SCREST,SCCLNM "RTN","SDM",70,0) G ^SDM0 "RTN","SDM",71,0) ; "RTN","SDM",72,0) CHKSO S COV=$S($P(^DPT(DFN,"S",Y,0),U,11)=1:" (COLLATERAL)",1:""),HY=Y,SSC=^(0),SDAT16=$S($D(^SD(409.1,+$P(SSC,U,16),0)):$P(^(0),U),1:"") "RTN","SDM",73,0) F SDJ=3,4,5 I $P(^DPT(DFN,"S",HY,0),U,SDJ)]"" S Y=$P(^(0),U,SDJ) W:$X>9 ! W ?10,"*" D DT^SDM0 W ?32,$S(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG") "RTN","SDM",74,0) S SDLN="" F J=0:0 S J=$O(^SC(+SSC,"S",HY,1,J)) Q:'J I $D(^(J,0)),+^(0)=DFN S SDLN="("_$P(^(0),U,2)_" MINUTES) " Q "RTN","SDM",75,0) S Y=HY Q "RTN","SDM",76,0) ; "RTN","SDM",77,0) END D KVAR^VADPT K SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR,HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL,SSC,STARTDAY,STR "RTN","SDM",78,0) K WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM,SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS I $D(SDMM) K:'SDMM SDMM "RTN","SDM",79,0) I '$D(SDMLT) K SDMLT1 "RTN","SDM",80,0) Q "RTN","SDM",81,0) ; "RTN","SDM",82,0) OERR S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP G SDM "RTN","SDM",83,0) ; "RTN","SDM",84,0) HELP W !,"YES - TO DISPLAY FUTURE APPOINTMENTS",!,"NO - FUTURE APPOINTMENTS NOT DISPLAYED" G PEND "RTN","SDM",85,0) ; "RTN","SDM",86,0) CNAM(SDCL) ;Return clinic name "RTN","SDM",87,0) ;Input: SDCL=clinic ien "RTN","SDM",88,0) N SDX "RTN","SDM",89,0) S SDX=$P($G(^SC(+SDCL,0)),U) "RTN","SDM",90,0) Q $S($L(SDX):SDX,1:"this clinic") "VER") 8.0^22.0 "^DD",409.76,409.76,0) FIELD^^41^6 "^DD",409.76,409.76,0,"DDA") N "^DD",409.76,409.76,0,"DT") 2970710 "^DD",409.76,409.76,0,"ID",11) D EN^DDIOL($P(^(1),U,1)) "^DD",409.76,409.76,0,"IX","B",409.76,.01) "^DD",409.76,409.76,0,"IX","D",409.76,11) "^DD",409.76,409.76,0,"NM","TRANSMITTED OUTPATIENT ENCOUNTER ERROR CODE") "^DD",409.76,409.76,0,"PT",409.75,.02) "^DD",409.76,409.76,0,"VRPK") SD "^DD",409.76,409.76,.01,0) ERROR CODE^RF^^0;1^K:$L(X)>10!($L(X)<1)!'(X'?1P.E) X "^DD",409.76,409.76,.01,.1) Error Code "^DD",409.76,409.76,.01,1,0) ^.1 "^DD",409.76,409.76,.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,409.76,.01,3) Enter an error code to use (1-10 characters) "^DD",409.76,409.76,.01,21,0) ^^2^2^2970623^^^ "^DD",409.76,409.76,.01,21,1,0) Error code denoting why an entry in the Transmitted Outpatient Encounter "^DD",409.76,409.76,.01,21,2,0) file could not be transmitted or successfully processed. "^DD",409.76,409.76,.01,23,0) ^^1^1^2970623^ "^DD",409.76,409.76,.01,23,1,0) "^DD",409.76,409.76,.01,"DT") 2960430 "^DD",409.76,409.76,.02,0) SOURCE OF ERROR^RS^N:NPCD;V:VISTA;T:HL7 TRANSMISSION;^0;2^Q "^DD",409.76,409.76,.02,3) Enter the source of the error. "^DD",409.76,409.76,.02,21,0) ^^1^1^2970710^ "^DD",409.76,409.76,.02,21,1,0) This set of codes indicates the source of the error. "^DD",409.76,409.76,.02,"DT") 2970710 "^DD",409.76,409.76,11,0) ERROR CODE DESCRIPTION^F^^1;1^K:$L(X)>80!($L(X)<1) X "^DD",409.76,409.76,11,.1) Error Code Description "^DD",409.76,409.76,11,1,0) ^.1^^-1 "^DD",409.76,409.76,11,1,2,0) 409.76^D "^DD",409.76,409.76,11,1,2,1) S ^SD(409.76,"D",$E(X,1,30),DA)="" "^DD",409.76,409.76,11,1,2,2) K ^SD(409.76,"D",$E(X,1,30),DA) "^DD",409.76,409.76,11,1,2,"%D",0) ^^1^1^2971210^ "^DD",409.76,409.76,11,1,2,"%D",1,0) This is used to aid in the lookup of error codes. "^DD",409.76,409.76,11,1,2,"DT") 2971210 "^DD",409.76,409.76,11,3) Enter a description of the error code (1-80 characters) "^DD",409.76,409.76,11,21,0) ^^1^1^2960524^^ "^DD",409.76,409.76,11,21,1,0) Free text description of the error code. "^DD",409.76,409.76,11,"DT") 2980120 "^DD",409.76,409.76,21,0) CORRECTIVE ACTION DESCRIPTION^409.7621^^2;0 "^DD",409.76,409.76,21,21,0) ^^3^3^2971022^ "^DD",409.76,409.76,21,21,1,0) This field describes the actions necessary to correct the error. "^DD",409.76,409.76,21,21,2,0) This is the text which would be viewed by a user when using the Incomplete "^DD",409.76,409.76,21,21,3,0) Encounter Management Tools. "^DD",409.76,409.76,31,0) VALIDATION LOGIC^K^^CHK;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",409.76,409.76,31,3) Enter routine entry point to perform error validation "^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) This field should 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 contains the logic that needs to be executed in order to validate the "^DD",409.76,409.76,31,21,4,0) data. If the data does not validate correctly the error code from this "^DD",409.76,409.76,31,21,5,0) entry will be used. The function call contained within this field uses "^DD",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) Data - The value being validated. "^DD",409.76,409.76,31,21,9,0) "^DD",409.76,409.76,31,21,10,0) Returns "^DD",409.76,409.76,31,21,11,0) RES - Result of the function call "^DD",409.76,409.76,31,21,12,0) 1 if entry passed validation "^DD",409.76,409.76,31,21,13,0) 0 if entry does not pass validation "^DD",409.76,409.76,31,"DT") 2970605 "^DD",409.76,409.76,41,0) CORRECTION LOGIC^K^^COR;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",409.76,409.76,41,3) This is the code that will need to be executed to correct this 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) This field should 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 contains the logic that needs to be executed in order to allow the "^DD",409.76,409.76,41,21,4,0) user to correct the error. The function call contained within this field "^DD",409.76,409.76,41,21,5,0) uses the following variables: "^DD",409.76,409.76,41,21,6,0) Returns "^DD",409.76,409.76,41,21,7,0) RES - Result of the function call "^DD",409.76,409.76,41,21,8,0) 0 - if the corrective action was not successful "^DD",409.76,409.76,41,21,9,0) 1 - if the corrective action succeeded "^DD",409.76,409.76,41,21,10,0) "^DD",409.76,409.76,41,21,11,0) This function call makes the assumption that the ^TMP("SCENI XMT",$J,0) "^DD",409.76,409.76,41,21,12,0) global from the Incomplete Encounter Management List Manager tool is "^DD",409.76,409.76,41,21,13,0) available to retrieve the pointer from the TRANSMITTED OUTPATIENT "^DD",409.76,409.76,41,21,14,0) ENCOUNTER FILE (#409.73) which is used to check the entry and "^DD",409.76,409.76,41,21,15,0) retreive the entry from the TRANSMITTED OUTPATIENT ENCOUNTER ERROR FILE "^DD",409.76,409.76,41,21,16,0) (#409.75). "^DD",409.76,409.76,41,"DT") 2970710 "^DD",409.76,409.7621,0) CORRECTIVE ACTION DESCRIPTION SUB-FIELD^^.01^1 "^DD",409.76,409.7621,0,"DT") 2970710 "^DD",409.76,409.7621,0,"NM","CORRECTIVE ACTION DESCRIPTION") "^DD",409.76,409.7621,0,"UP") 409.76 "^DD",409.76,409.7621,.01,0) CORRECTIVE ACTION DESCRIPTION^W^^0;1^Q "^DD",409.76,409.7621,.01,3) Enter the corrective action a user will need to take in order to correct this error. "^DD",409.76,409.7621,.01,21,0) ^^1^1^2971022^^^ "^DD",409.76,409.7621,.01,21,1,0) This is the corrective action needed to correct this error situation. "^DD",409.76,409.7621,.01,"DT") 2970710 "^DD",409.92,409.92,0) FIELD^^16^17 "^DD",409.92,409.92,0,"DDA") N "^DD",409.92,409.92,0,"DT") 2980408 "^DD",409.92,409.92,0,"ID",2) W " ",$P(^(0),U,3) "^DD",409.92,409.92,0,"ID",4) W " ",$P(^(0),U,5) "^DD",409.92,409.92,0,"IX","AC",409.92,16) "^DD",409.92,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","ACRP REPORT TEMPLATE PARAMETER") "^DD",409.92,409.92,0,"VRPK") SD "^DD",409.92,409.92,.01,0) ORDER NUMBER^RF^^0;1^K:$L(X)>4!($L(X)<4)!'(X?4N) X "^DD",409.92,409.92,.01,1,0) ^.1 "^DD",409.92,409.92,.01,1,1,0) 409.92^B "^DD",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),DA) "^DD",409.92,409.92,.01,3) Answer must be 4 characters in length, all numeric; where the first 2 characters represent the order of the major category, the second 2 characters represent the order of the minor category. "^DD",409.92,409.92,.01,21,0) ^^5^5^2980529^ "^DD",409.92,409.92,.01,21,1,0) This is a 4 digit numeric value that determines where (and in what "^DD",409.92,409.92,.01,21,2,0) order) each data element will be displayed by ^DIR for selection in the "^DD",409.92,409.92,.01,21,3,0) 'ACRP Ad Hoc Report'. The first to digits determine the order of the "^DD",409.92,409.92,.01,21,4,0) major category of this data element. The second two digits determine the "^DD",409.92,409.92,.01,21,5,0) order of the subcategory of this data element (within the major category). "^DD",409.92,409.92,.01,"DT") 2980319 "^DD",409.92,409.92,1,0) MAJOR CATEGORY (INTERNAL)^F^^0;2^K:$L(X)>2!($L(X)<2) X "^DD",409.92,409.92,1,3) Answer must be 2 characters in length. "^DD",409.92,409.92,1,21,0) ^^4^4^2980529^ "^DD",409.92,409.92,1,21,1,0) This is the internal value or acronym that represents the major category "^DD",409.92,409.92,1,21,2,0) of this data element. The 4 character acronym created by concatinating "^DD",409.92,409.92,1,21,3,0) the major category acromym with the subcategory acronym is used as a "^DD",409.92,409.92,1,21,4,0) unique identifier for this data element. "^DD",409.92,409.92,1,"DT") 2980319 "^DD",409.92,409.92,2,0) MAJOR CATEGORY (EXTERNAL)^F^^0;3^K:$L(X)>40!($L(X)<1) X "^DD",409.92,409.92,2,3) Answer must be 1-40 characters in length. "^DD",409.92,409.92,2,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,2,21,1,0) This is the external representation of the major category (conceptual "^DD",409.92,409.92,2,21,2,0) group) of this data element. "^DD",409.92,409.92,2,"DT") 2980408 "^DD",409.92,409.92,3,0) MINOR CATEGORY (INTERNAL)^F^^0;4^K:$L(X)>2!($L(X)<2) X "^DD",409.92,409.92,3,3) Answer must be 2 characters in length. "^DD",409.92,409.92,3,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,3,21,1,0) This is the internal value or acronym that represents the subcategory "^DD",409.92,409.92,3,21,2,0) of this data element. "^DD",409.92,409.92,3,"DT") 2980319 "^DD",409.92,409.92,4,0) MINOR CATEGORY (EXTERNAL)^F^^0;5^K:$L(X)>40!($L(X)<1) X "^DD",409.92,409.92,4,1,0) ^.1 "^DD",409.92,409.92,4,1,1,0) 409.92^C^MUMPS "^DD",409.92,409.92,4,1,1,1) S ^SD(409.92,"C",X,DA)="" "^DD",409.92,409.92,4,1,1,2) K ^SD(409.92,"C",X,DA) "^DD",409.92,409.92,4,1,1,"DT") 2980319 "^DD",409.92,409.92,4,3) Answer must be 1-40 characters in length. "^DD",409.92,409.92,4,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,4,21,1,0) This is the external representation of the subcategory (actual data value) "^DD",409.92,409.92,4,21,2,0) of this data element. "^DD",409.92,409.92,4,"DT") 2980408 "^DD",409.92,409.92,5,0) TYPE^S^D:DATE;P:POINTER;F:FIELD;N:NUMBER;T:TEXT;C:COMPUTED;PP:POINTER/POINTER;S:SET OF CODES;^0;6^Q "^DD",409.92,409.92,5,3) Indicates the type of data this element is. "^DD",409.92,409.92,5,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,5,21,1,0) This field defines the type of data this data element consists of and "^DD",409.92,409.92,5,21,2,0) determines how it will be manipulated generically. "^DD",409.92,409.92,5,"DT") 2980319 "^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) Answer must be 1-245 characters in length. Contains 'where' (global or field) or execute code that sets up DIR array for set of codes. "^DD",409.92,409.92,6,8.5) @ "^DD",409.92,409.92,6,9) @ "^DD",409.92,409.92,6,21,0) ^^9^9^2980529^ "^DD",409.92,409.92,6,21,1,0) This indicates where or how this data type is found or code to set up "^DD",409.92,409.92,6,21,2,0) DIR(0). Specifically: "^DD",409.92,409.92,6,21,3,0) "^DD",409.92,409.92,6,21,4,0) Data type: Value: "^DD",409.92,409.92,6,21,5,0) ------------------ ------------------------------- "^DD",409.92,409.92,6,21,6,0) FIELD "file#,field#" "^DD",409.92,409.92,6,21,7,0) POINTER global root of file pointed to "^DD",409.92,409.92,6,21,8,0) POINTER/POINTER "globalroot;field#" "^DD",409.92,409.92,6,21,9,0) SET OF CODES execute code to set DIR(0) "^DD",409.92,409.92,6,"DT") 2980319 "^DD",409.92,409.92,7,0) TYPE SCREEN^F^^8;E1,245^K:$L(X)>245!($L(X)<1) X "^DD",409.92,409.92,7,3) Answer must be 1-245 characters in length. Value for DIC("S") or input transform. "^DD",409.92,409.92,7,8.5) @ "^DD",409.92,409.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") or parameters for DIC(0), "^DD",409.92,409.92,7,21,2,0) specifically: "^DD",409.92,409.92,7,21,3,0) "^DD",409.92,409.92,7,21,4,0) Data type: Value: "^DD",409.92,409.92,7,21,5,0) -------------------- ------------------------------------- "^DD",409.92,409.92,7,21,6,0) DATE value for DIR(0) (required) "^DD",409.92,409.92,7,21,7,0) NUMBER value for DIR(0) (required) "^DD",409.92,409.92,7,21,8,0) POINTER screen logic for DIC("S") (optional) "^DD",409.92,409.92,7,21,9,0) TEXT value for DIR(0) (required) "^DD",409.92,409.92,7,"DT") 2980319 "^DD",409.92,409.92,8,0) CHOICE METHOD^S^L:LIST;R:RANGE;LR:LIST OR RANGE;^0;9^Q "^DD",409.92,409.92,8,3) Determines selection method(s) allowed for this data element. "^DD",409.92,409.92,8,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,8,21,1,0) This determines the choice method(s) the user will be allowed when "^DD",409.92,409.92,8,21,2,0) selecting items for this data element. "^DD",409.92,409.92,8,"DT") 2980319 "^DD",409.92,409.92,9,0) NUMBER OF CHOICES^NJ3,0^^0;10^K:+X'=X!(X>999)!(X<0)!(X?.E1"."1N.N) X "^DD",409.92,409.92,9,3) Type a Number between 0 and 999, 0 Decimal Digits. Limits the number of choices for list selection. "^DD",409.92,409.92,9,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,9,21,1,0) This determines the maximum number of item choices a user is allowed "^DD",409.92,409.92,9,21,2,0) for this data element. "^DD",409.92,409.92,9,"DT") 2980319 "^DD",409.92,409.92,10,0) CODE TO SET 'SDX'^K^^11;E1,245^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)=external value. "^DD",409.92,409.92,10,9) @ "^DD",409.92,409.92,10,21,0) ^^6^6^2980529^ "^DD",409.92,409.92,10,21,1,0) When an encounter is being evaluated, the actual data values for this "^DD",409.92,409.92,10,21,2,0) data element are extracted into an array where: "^DD",409.92,409.92,10,21,3,0) "^DD",409.92,409.92,10,21,4,0) SDX(n)=internal value^external value "^DD",409.92,409.92,10,21,5,0) "^DD",409.92,409.92,10,21,6,0) This field contains code which, when executed, will create the SDX array. "^DD",409.92,409.92,10,"DT") 2980319 "^DD",409.92,409.92,11,0) OUTPUT TRANSFORM^K^^12;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",409.92,409.92,11,3) This is Standard MUMPS code. Performs output transform (where SDX="internal value^external value" or "int;int^ext / ext" for pointer/pointer data types). "^DD",409.92,409.92,11,9) @ "^DD",409.92,409.92,11,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,11,21,1,0) This field contains code which, when executed, will transform the values "^DD",409.92,409.92,11,21,2,0) in the SDX(n) array into a different format, if desired. "^DD",409.92,409.92,11,"DT") 2980319 "^DD",409.92,409.92,12,0) CODE TO SET 'SDIRQ'^K^^13;E1,245^K:$L(X)>245 X D:$D(X) ^DIM "^DD",409.92,409.92,12,3) This is Standard MUMPS code. Code that sets SDIRQ array for use as DIR("?"). "^DD",409.92,409.92,12,9) @ "^DD",409.92,409.92,12,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,12,21,1,0) This field contains code that sets the SDIRQ array to help text used as "^DD",409.92,409.92,12,21,2,0) the DIR("?") array. "^DD",409.92,409.92,12,"DT") 2980319 "^DD",409.92,409.92,13,0) ADDITIONAL LIMITATIONS^F^^0;14^K:$L(X)>4!($L(X)<4) X "^DD",409.92,409.92,13,3) Answer must be 4 characters in length. Represents synonymous additional limitations to apply when evaluating limitations. "^DD",409.92,409.92,13,21,0) ^^3^3^2980529^ "^DD",409.92,409.92,13,21,1,0) This field contains the acronym representing an additional data element "^DD",409.92,409.92,13,21,2,0) to be applied synonymously when evaluating this data element as a "^DD",409.92,409.92,13,21,3,0) limitation. "^DD",409.92,409.92,13,"DT") 2980319 "^DD",409.92,409.92,14,0) PRINT FIELD LEVEL^S^0:EXCLUDE;1:ENCOUNTER DETAIL ONLY;2:ALL DETAIL TYPES;^0;15^Q "^DD",409.92,409.92,14,3) Determines which data element are selectable for which patient detail types (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 level of detail this data element is related "^DD",409.92,409.92,14,21,2,0) to and restricts selection accordingly. "^DD",409.92,409.92,14,"DT") 2980319 "^DD",409.92,409.92,15,0) MULTIPLE VALUED^S^0:NO;1:YES;^0;16^Q "^DD",409.92,409.92,15,3) Indicates if this data element is potentially multiply valued. "^DD",409.92,409.92,15,21,0) ^^2^2^2980529^ "^DD",409.92,409.92,15,21,1,0) This indicates if the actual data for this data element can potentially "^DD",409.92,409.92,15,21,2,0) be multiply valued. "^DD",409.92,409.92,15,"DT") 2980319 "^DD",409.92,409.92,16,0) ACRONYM^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) 409.92^AC^MUMPS "^DD",409.92,409.92,16,1,1,1) S ^SD(409.92,"C",X,DA)="" "^DD",409.92,409.92,16,1,1,2) K ^SD(409.92,"C",X,DA) "^DD",409.92,409.92,16,1,1,"%D",0) ^^1^1^2980319^^^ "^DD",409.92,409.92,16,1,1,"%D",1,0) Adds acronym to 'C' x-ref. for lookup. "^DD",409.92,409.92,16,1,1,"DT") 2980319 "^DD",409.92,409.92,16,3) Answer must be 4 characters in length. "^DD",409.92,409.92,16,21,0) ^^3^3^2980529^ "^DD",409.92,409.92,16,21,1,0) This field contains the acronym which uniquely identifies this data "^DD",409.92,409.92,16,21,2,0) element. It is a 4 character value which consists of the internal "^DD",409.92,409.92,16,21,3,0) values of the major category and subcategory of this data element. "^DD",409.92,409.92,16,"DT") 2980319 "^DIC",409.76,409.76,0) TRANSMITTED OUTPATIENT ENCOUNTER ERROR CODE^409.76 "^DIC",409.76,409.76,0,"GL") ^SD(409.76, "^DIC",409.76,409.76,"%D",0) ^^6^6^2970623^^^^ "^DIC",409.76,409.76,"%D",1,0) This table file contains a list of all error codes that the National "^DIC",409.76,409.76,"%D",2,0) Patient Care Database will report when processing an encounter. "^DIC",409.76,409.76,"%D",3,0) "^DIC",409.76,409.76,"%D",4,0) If an entry needs to be added, modified or deleted a patch will be issued "^DIC",409.76,409.76,"%D",5,0) instructing the site how to make the change. Otherwise, this table should "^DIC",409.76,409.76,"%D",6,0) not be edited in anyway by the site. "^DIC",409.76,"B","TRANSMITTED OUTPATIENT ENCOUNTER ERROR CODE",409.76) "^DIC",409.92,409.92,0) ACRP REPORT TEMPLATE PARAMETER^409.92 "^DIC",409.92,409.92,0,"GL") ^SD(409.92, "^DIC",409.92,409.92,"%D",0) ^^4^4^2980705^^^^ "^DIC",409.92,409.92,"%D",1,0) This file contains the parameters necessary to manipulate the various data "^DIC",409.92,409.92,"%D",2,0) elements used by the 'ACRP Ad Hoc Report' [SCRPW AD HOC REPORT]. "^DIC",409.92,409.92,"%D",3,0) "^DIC",409.92,409.92,"%D",4,0) *** THE CONTENTS OF THIS FILE SHOULD NOT BE EDITED *** "^DIC",409.92,"B","ACRP REPORT TEMPLATE PARAMETER",409.92) **END** **END**