KIDS Distribution saved on Sep 18, 2007@15:57:19 DG*5.3*755,PX*1*186,SD*5.3*516 **KIDS**:DG*5.3*755^PX*1.0*186^SD*5.3*516^ **INSTALL NAME** DG*5.3*755 "BLD",6657,0) DG*5.3*755^REGISTRATION^0^3070918^y "BLD",6657,1,0) ^^2^2^3070628^ "BLD",6657,1,1,0) Please refer to patch DG*5.3*755 in the National Patch Module for a "BLD",6657,1,2,0) complete description of this patch. "BLD",6657,4,0) ^9.64PA^29.11^1 "BLD",6657,4,29.11,0) 29.11 "BLD",6657,4,29.11,2,0) ^9.641^29.11^1 "BLD",6657,4,29.11,2,29.11,0) MST HISTORY (File-top level) "BLD",6657,4,29.11,2,29.11,1,0) ^9.6411^4^1 "BLD",6657,4,29.11,2,29.11,1,4,0) PROVIDER DETERMINING STATUS "BLD",6657,4,29.11,222) y^n^p^^^^n^^n "BLD",6657,4,29.11,224) "BLD",6657,4,"APDD",29.11,29.11) "BLD",6657,4,"APDD",29.11,29.11,4) "BLD",6657,4,"B",29.11,29.11) "BLD",6657,6.3) 3 "BLD",6657,"KRN",0) ^9.67PA^8989.52^19 "BLD",6657,"KRN",.4,0) .4 "BLD",6657,"KRN",.401,0) .401 "BLD",6657,"KRN",.402,0) .402 "BLD",6657,"KRN",.403,0) .403 "BLD",6657,"KRN",.5,0) .5 "BLD",6657,"KRN",.84,0) .84 "BLD",6657,"KRN",3.6,0) 3.6 "BLD",6657,"KRN",3.8,0) 3.8 "BLD",6657,"KRN",9.2,0) 9.2 "BLD",6657,"KRN",9.8,0) 9.8 "BLD",6657,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",6657,"KRN",9.8,"NM",1,0) DGPMDD^^0^B2946679 "BLD",6657,"KRN",9.8,"NM","B","DGPMDD",1) "BLD",6657,"KRN",19,0) 19 "BLD",6657,"KRN",19.1,0) 19.1 "BLD",6657,"KRN",101,0) 101 "BLD",6657,"KRN",409.61,0) 409.61 "BLD",6657,"KRN",771,0) 771 "BLD",6657,"KRN",870,0) 870 "BLD",6657,"KRN",8989.51,0) 8989.51 "BLD",6657,"KRN",8989.52,0) 8989.52 "BLD",6657,"KRN",8994,0) 8994 "BLD",6657,"KRN","B",.4,.4) "BLD",6657,"KRN","B",.401,.401) "BLD",6657,"KRN","B",.402,.402) "BLD",6657,"KRN","B",.403,.403) "BLD",6657,"KRN","B",.5,.5) "BLD",6657,"KRN","B",.84,.84) "BLD",6657,"KRN","B",3.6,3.6) "BLD",6657,"KRN","B",3.8,3.8) "BLD",6657,"KRN","B",9.2,9.2) "BLD",6657,"KRN","B",9.8,9.8) "BLD",6657,"KRN","B",19,19) "BLD",6657,"KRN","B",19.1,19.1) "BLD",6657,"KRN","B",101,101) "BLD",6657,"KRN","B",409.61,409.61) "BLD",6657,"KRN","B",771,771) "BLD",6657,"KRN","B",870,870) "BLD",6657,"KRN","B",8989.51,8989.51) "BLD",6657,"KRN","B",8989.52,8989.52) "BLD",6657,"KRN","B",8994,8994) "BLD",6657,"QUES",0) ^9.62^^ "BLD",6657,"REQB",0) ^9.611^1^1 "BLD",6657,"REQB",1,0) DG*5.3*129^2 "BLD",6657,"REQB","B","DG*5.3*129",1) "FIA",29.11) MST HISTORY "FIA",29.11,0) ^DGMS(29.11, "FIA",29.11,0,0) 29.11OID "FIA",29.11,0,1) y^n^p^^^^n^^n "FIA",29.11,0,10) "FIA",29.11,0,11) "FIA",29.11,0,"RLRO") "FIA",29.11,0,"VR") 5.3^DG "FIA",29.11,29.11) 1 "FIA",29.11,29.11,4) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 755^3070918^123456810 "PKG",5,22,1,"PAH",1,1,0) ^^2^2^3070918 "PKG",5,22,1,"PAH",1,1,1,0) Please refer to patch DG*5.3*755 in the National Patch Module for a "PKG",5,22,1,"PAH",1,1,2,0) complete description of this patch. "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") NO "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") NO "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") NO "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") 1 "RTN","DGPMDD") 0^1^B2946679 "RTN","DGPMDD",1,0) DGPMDD ;ALB/MRL - FILE 405 DD CALLS; 27 JAN 89] ; 6/27/07 11:05am "RTN","DGPMDD",2,0) ;;5.3;Registration;**41,129,755**;Aug 13, 1993;Build 3 "RTN","DGPMDD",3,0) ID ;Display Identifiers "RTN","DGPMDD",4,0) N DGPMDISP "RTN","DGPMDD",5,0) S DGPMDD(1)=$S($D(^DPT(+$P(DGPMDD,"^",3),0)):^(0),1:"") "RTN","DGPMDD",6,0) S DGPMDISP(1)=$P(DGPMDD(1),"^")_" ("_$P(DGPMDD(1),"^",9)_")" "RTN","DGPMDD",7,0) S DGPMDISP(1,"F")="?30" "RTN","DGPMDD",8,0) S DGPMDISP(2)=$S($D(^DG(405.3,+$P(DGPMDD,"^",2),0)):$P(^(0),"^"),1:"TRANSACTION UNKNOWN")_": " "RTN","DGPMDD",9,0) S DGPMDISP(2)=DGPMDISP(2)_$S($D(^DG(405.1,+$P(DGPMDD,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN MOVEMENT TYPE") "RTN","DGPMDD",10,0) S DGPMDISP(2,"F")="!?15" "RTN","DGPMDD",11,0) D EN^DDIOL(.DGPMDISP) "RTN","DGPMDD",12,0) K DGPMDD "RTN","DGPMDD",13,0) Q "RTN","DGPMDD",14,0) ; "RTN","DGPMDD",15,0) SCREEN(Y,DA,DGDT) ;screen called from various files/fields - select active providers in file 200 "RTN","DGPMDD",16,0) ;File 405 - Patient Movement: "RTN","DGPMDD",17,0) ; Field .08 - Primary Care Physician "RTN","DGPMDD",18,0) ; Field .19 - Attending Physician "RTN","DGPMDD",19,0) ;File 2 - Patient: "RTN","DGPMDD",20,0) ; Field .104 - Provider "RTN","DGPMDD",21,0) ; Field .1041 - Attending Physician "RTN","DGPMDD",22,0) ;File 41.1 - Scheduled Admission: "RTN","DGPMDD",23,0) ; Field 5 - Provider "RTN","DGPMDD",24,0) ;File 45 - PTF, Subfile 45.02 (Field 50) - 501: "RTN","DGPMDD",25,0) ; Subfield 24 - Provider "RTN","DGPMDD",26,0) ;File 45.7 - Facility Treating Speciality, Subfile 45.701 (Field 10): "RTN","DGPMDD",27,0) ; Subfield .01 - Providers "RTN","DGPMDD",28,0) ;INPUT: Y=ien if file 200 "RTN","DGPMDD",29,0) ; DA=record edited "RTN","DGPMDD",30,0) ; DGDT=date, either today's or date of movement "RTN","DGPMDD",31,0) ;date of movement is used for fields .19 (attending) & .08 (primary) in file 405. "RTN","DGPMDD",32,0) ;OUTPUT: 1 to select; 0 to not select "RTN","DGPMDD",33,0) ; "RTN","DGPMDD",34,0) ; begin patch *755* "RTN","DGPMDD",35,0) ; DBIA #2349 - ACTIVE PROVIDER will be used for validation. "RTN","DGPMDD",36,0) ; The INACTIVE DATE (#53.4) field will no longer be used. "RTN","DGPMDD",37,0) ; New Input selection logic... "RTN","DGPMDD",38,0) ; If input selection has the PROVIDER security key... "RTN","DGPMDD",39,0) ; the TERMINATION DATE (#9.2) and the PERSON CLASS (#8932.1) fields "RTN","DGPMDD",40,0) ; will be used to determine if selection is active in the "RTN","DGPMDD",41,0) ; NEW PERSON (#200) file for a given date. "RTN","DGPMDD",42,0) ; "RTN","DGPMDD",43,0) ;S:'+$G(DA) DA=0 S:'+$G(DGDT) DGDT=DT I '+$G(Y) Q 0 "RTN","DGPMDD",44,0) ;N DGINACT,DGY S DGY=0,DGDT=$P(DGDT,".") "RTN","DGPMDD",45,0) ;I $D(^VA(200,"AK.PROVIDER",$P($G(^VA(200,+Y,0)),U),+Y)) D "RTN","DGPMDD",46,0) ;.S DGY=0,DGINACT=$G(^VA(200,+Y,"PS")) "RTN","DGPMDD",47,0) ;.S DGY=$S(DGINACT']"":1,'+$P(DGINACT,U,4):1,DGDT'>+$P(DGINACT,U,4):1,1:0) "RTN","DGPMDD",48,0) ; "RTN","DGPMDD",49,0) N DGY S DGY=0 "RTN","DGPMDD",50,0) I +$G(Y) D "RTN","DGPMDD",51,0) . S:'+$G(DA) DA=0 S:'+$G(DGDT) DGDT=DT S DGDT=$P(DGDT,".") "RTN","DGPMDD",52,0) . I $D(^VA(200,"AK.PROVIDER",$P($G(^VA(200,+Y,0)),U),+Y)) D "RTN","DGPMDD",53,0) . . I $$ACTIVPRV^PXAPI(+Y,DGDT) S DGY=1 ;DBIA #2349 "RTN","DGPMDD",54,0) ; end patch *755* "RTN","DGPMDD",55,0) Q DGY "RTN","DGPMDD",56,0) ; "RTN","DGPMDD",57,0) HELP(DA,DGDT) ;executable help called from various files/fields - display active providers in file 200 "RTN","DGPMDD",58,0) ;File 405 - Patient Movement: "RTN","DGPMDD",59,0) ; Field .08 - Primary Care Physician "RTN","DGPMDD",60,0) ; Field .19 - Attending Physician "RTN","DGPMDD",61,0) ;File 2 - Patient: "RTN","DGPMDD",62,0) ; Field .104 - Provider "RTN","DGPMDD",63,0) ; Field .1041 - Attending Physician "RTN","DGPMDD",64,0) ;File 41.1 - Scheduled Admission: "RTN","DGPMDD",65,0) ; Field 5 - Provider "RTN","DGPMDD",66,0) ;File 45 - PTF, Subfile 45.02 (Field 50) - 501: "RTN","DGPMDD",67,0) ; Subfield 24 - Provider "RTN","DGPMDD",68,0) ;File 45.7 - Facility Treating Speciality, Subfile 45.701 (Field 10): "RTN","DGPMDD",69,0) ; Subfield .01 - Providers "RTN","DGPMDD",70,0) ;INPUT: DA=record edited "RTN","DGPMDD",71,0) ; DGDT=date, either today's or date of movement "RTN","DGPMDD",72,0) ;date of movement is used for fields .08 (attending) & .19 (primary) in file 405. "RTN","DGPMDD",73,0) S:'+$G(DGDT) DGDT=DT I '+$G(DA) Q "RTN","DGPMDD",74,0) ;OUTPUT: display of active providers "RTN","DGPMDD",75,0) N D,DGINACT,DO,DIC,X "RTN","DGPMDD",76,0) S X="??",DIC="^VA(200,",DIC(0)="EQ",D="AK.PROVIDER" "RTN","DGPMDD",77,0) S DIC("S")="I $$SCREEN^DGPMDD(Y,DA,DGDT)" "RTN","DGPMDD",78,0) D IX^DIC "RTN","DGPMDD",79,0) Q "VER") 8.0^22.0 "^DD",29.11,29.11,4,0) PROVIDER DETERMINING STATUS^R*P200'X^VA(200,^0;4^S DIC("S")="I $$ACTIVPRV^PXAPI(Y,DT)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",29.11,29.11,4,1,0) ^.1 "^DD",29.11,29.11,4,1,1,0) 29.11^D "^DD",29.11,29.11,4,1,1,1) S ^DGMS(29.11,"D",$E(X,1,30),DA)="" "^DD",29.11,29.11,4,1,1,2) K ^DGMS(29.11,"D",$E(X,1,30),DA) "^DD",29.11,29.11,4,1,1,"%D",0) ^^1^1^2981211^ "^DD",29.11,29.11,4,1,1,"%D",1,0) Cross-reference on provider who determined MST status "^DD",29.11,29.11,4,1,1,"DT") 2981211 "^DD",29.11,29.11,4,3) Enter name of the provider making the MST status determination "^DD",29.11,29.11,4,12) Checks for both an active PERSON CLASS and no TERMINATION DATE "^DD",29.11,29.11,4,12.1) S DIC("S")="I $$ACTIVPRV^PXAPI(Y,DT)" "^DD",29.11,29.11,4,21,0) ^.001^1^1^3070620^^^^ "^DD",29.11,29.11,4,21,1,0) Pointer to the provider who determined the MST status of the patient "^DD",29.11,29.11,4,"DT") 3070621 **INSTALL NAME** PX*1.0*186 "BLD",6658,0) PX*1.0*186^PCE PATIENT CARE ENCOUNTER^0^3070918^y "BLD",6658,1,0) ^^2^2^3070628^ "BLD",6658,1,1,0) Please refer to patch PX*1.0*186 in the National Patch Module for a "BLD",6658,1,2,0) complete description of this patch. "BLD",6658,4,0) ^9.64PA^^ "BLD",6658,6.3) 3 "BLD",6658,"KRN",0) ^9.67PA^8989.52^19 "BLD",6658,"KRN",.4,0) .4 "BLD",6658,"KRN",.401,0) .401 "BLD",6658,"KRN",.402,0) .402 "BLD",6658,"KRN",.403,0) .403 "BLD",6658,"KRN",.5,0) .5 "BLD",6658,"KRN",.84,0) .84 "BLD",6658,"KRN",3.6,0) 3.6 "BLD",6658,"KRN",3.8,0) 3.8 "BLD",6658,"KRN",9.2,0) 9.2 "BLD",6658,"KRN",9.8,0) 9.8 "BLD",6658,"KRN",9.8,"NM",0) ^9.68A^9^8 "BLD",6658,"KRN",9.8,"NM",2,0) PXBPORD^^0^B3025931 "BLD",6658,"KRN",9.8,"NM",3,0) PXBPPRV^^0^B43404885 "BLD",6658,"KRN",9.8,"NM",4,0) PXBPPRV1^^0^B16413731 "BLD",6658,"KRN",9.8,"NM",5,0) PXAIPRVV^^0^B7178260 "BLD",6658,"KRN",9.8,"NM",6,0) PXAPIUTL^^0^B833210 "BLD",6658,"KRN",9.8,"NM",7,0) PXBGPRV^^0^B43042405 "BLD",6658,"KRN",9.8,"NM",8,0) PXBGPRV2^^0^B43180036 "BLD",6658,"KRN",9.8,"NM",9,0) PXKMAIN2^^0^B10938982 "BLD",6658,"KRN",9.8,"NM","B","PXAIPRVV",5) "BLD",6658,"KRN",9.8,"NM","B","PXAPIUTL",6) "BLD",6658,"KRN",9.8,"NM","B","PXBGPRV",7) "BLD",6658,"KRN",9.8,"NM","B","PXBGPRV2",8) "BLD",6658,"KRN",9.8,"NM","B","PXBPORD",2) "BLD",6658,"KRN",9.8,"NM","B","PXBPPRV",3) "BLD",6658,"KRN",9.8,"NM","B","PXBPPRV1",4) "BLD",6658,"KRN",9.8,"NM","B","PXKMAIN2",9) "BLD",6658,"KRN",19,0) 19 "BLD",6658,"KRN",19.1,0) 19.1 "BLD",6658,"KRN",101,0) 101 "BLD",6658,"KRN",409.61,0) 409.61 "BLD",6658,"KRN",771,0) 771 "BLD",6658,"KRN",870,0) 870 "BLD",6658,"KRN",8989.51,0) 8989.51 "BLD",6658,"KRN",8989.52,0) 8989.52 "BLD",6658,"KRN",8994,0) 8994 "BLD",6658,"KRN","B",.4,.4) "BLD",6658,"KRN","B",.401,.401) "BLD",6658,"KRN","B",.402,.402) "BLD",6658,"KRN","B",.403,.403) "BLD",6658,"KRN","B",.5,.5) "BLD",6658,"KRN","B",.84,.84) "BLD",6658,"KRN","B",3.6,3.6) "BLD",6658,"KRN","B",3.8,3.8) "BLD",6658,"KRN","B",9.2,9.2) "BLD",6658,"KRN","B",9.8,9.8) "BLD",6658,"KRN","B",19,19) "BLD",6658,"KRN","B",19.1,19.1) "BLD",6658,"KRN","B",101,101) "BLD",6658,"KRN","B",409.61,409.61) "BLD",6658,"KRN","B",771,771) "BLD",6658,"KRN","B",870,870) "BLD",6658,"KRN","B",8989.51,8989.51) "BLD",6658,"KRN","B",8989.52,8989.52) "BLD",6658,"KRN","B",8994,8994) "BLD",6658,"QUES",0) ^9.62^^ "BLD",6658,"REQB",0) ^9.611^6^6 "BLD",6658,"REQB",1,0) PX*1.0*105^2 "BLD",6658,"REQB",2,0) PX*1.0*124^2 "BLD",6658,"REQB",3,0) PX*1.0*152^2 "BLD",6658,"REQB",4,0) PX*1.0*27^2 "BLD",6658,"REQB",5,0) PX*1.0*108^2 "BLD",6658,"REQB",6,0) PX*1.0*69^2 "BLD",6658,"REQB","B","PX*1.0*105",1) "BLD",6658,"REQB","B","PX*1.0*108",5) "BLD",6658,"REQB","B","PX*1.0*124",2) "BLD",6658,"REQB","B","PX*1.0*152",3) "BLD",6658,"REQB","B","PX*1.0*27",4) "BLD",6658,"REQB","B","PX*1.0*69",6) "MBREQ") 0 "PKG",363,-1) 1^1 "PKG",363,0) PCE PATIENT CARE ENCOUNTER^PX^Patient Care Encounter (VA Parent package) "PKG",363,20,0) ^9.402P^^ "PKG",363,22,0) ^9.49I^1^1 "PKG",363,22,1,0) 1.0^2960812^2961106^1555 "PKG",363,22,1,"PAH",1,0) 186^3070918^123456810 "PKG",363,22,1,"PAH",1,1,0) ^^2^2^3070918 "PKG",363,22,1,"PAH",1,1,1,0) Please refer to patch PX*1.0*186 in the National Patch Module for a "PKG",363,22,1,"PAH",1,1,2,0) complete description of this patch. "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") NO "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") NO "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") NO "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","PXAIPRVV") 0^5^B7178260 "RTN","PXAIPRVV",1,0) PXAIPRVV ;ISL/JVS - VALIDATE THE PROVIDER DATA ;3/19/97 "RTN","PXAIPRVV",2,0) ;;1.0;PCE PATIENT CARE ENCOUNTER;**27,186**;Aug 12, 1996;Build 3 "RTN","PXAIPRVV",3,0) ; "RTN","PXAIPRVV",4,0) ; "RTN","PXAIPRVV",5,0) Q "RTN","PXAIPRVV",6,0) ; "RTN","PXAIPRVV",7,0) VAL ;--VALIDATE ENOUGH DATA "RTN","PXAIPRVV",8,0) ; "RTN","PXAIPRVV",9,0) ; "RTN","PXAIPRVV",10,0) ;----Missing a pointer to providers name "RTN","PXAIPRVV",11,0) I $G(PXAA("NAME"))']"" D Q:$G(STOP) "RTN","PXAIPRVV",12,0) .S STOP=1 ;--USED TO STOP DO LOOP "RTN","PXAIPRVV",13,0) .S PXAERRF=1 ;--FLAG INDICATES THERE IS AN ERR "RTN","PXAIPRVV",14,0) .S PXADI("DIALOG")=8390001.001 "RTN","PXAIPRVV",15,0) .S PXAERR(9)="NAME" "RTN","PXAIPRVV",16,0) .S PXAERR(11)=$G(PXAA("NAME")) "RTN","PXAIPRVV",17,0) .S PXAERR(12)="You are missing a pointer to the NEW PERSON file #200 that represents the providers name" "RTN","PXAIPRVV",18,0) ; "RTN","PXAIPRVV",19,0) ;----Not a pointer to NEW PERSON file#200 "RTN","PXAIPRVV",20,0) I $G(PXAA("NAME"))'["@" D 01^PXAIUPRV($G(PXAA("NAME"))) I $G(PXAIVAL)=1 K PXAIVAL,PXCA("ERROR") D Q:$G(STOP) "RTN","PXAIPRVV",21,0) .S STOP=1 "RTN","PXAIPRVV",22,0) .S PXAERRF=1 "RTN","PXAIPRVV",23,0) .S PXADI("DIALOG")=8390001.001 "RTN","PXAIPRVV",24,0) .S PXAERR(9)="NAME" "RTN","PXAIPRVV",25,0) .S PXAERR(11)=$G(PXAA("NAME")) "RTN","PXAIPRVV",26,0) .S PXAERR(12)=PXAERR(11)_" is NOT a pointer value to the NEW PERSON file #200" "RTN","PXAIPRVV",27,0) ; "RTN","PXAIPRVV",28,0) ;----Not have an active person class "RTN","PXAIPRVV",29,0) N CLASS "RTN","PXAIPRVV",30,0) S CLASS=+$$GET^XUA4A72($G(PXAA("NAME")),$P(+$G(^AUPNVSIT(PXAVISIT,0)),".")) I CLASS<0,'$G(PXAA("DELETE")) D "RTN","PXAIPRVV",31,0) .S STOP=1 "RTN","PXAIPRVV",32,0) .S PXAERRF=1 "RTN","PXAIPRVV",33,0) .S PXADI("DIALOG")=8390001.001 "RTN","PXAIPRVV",34,0) .S PXAERR(9)="NAME" "RTN","PXAIPRVV",35,0) .S PXAERR(11)=$G(PXAA("NAME")) "RTN","PXAIPRVV",36,0) .S PXAERR(12)="The Provider does not have an ACTIVE person class!" "RTN","PXAIPRVV",37,0) Q "RTN","PXAIPRVV",38,0) VAL04 ;---SET UP INFORMATION TO DELIVER ERROR "RTN","PXAIPRVV",39,0) D "RTN","PXAIPRVV",40,0) .S PXAERRF=1 "RTN","PXAIPRVV",41,0) .S PXADI("DIALOG")=8390001.002 "RTN","PXAIPRVV",42,0) .S PXAERR(9)="PRIMARY" "RTN","PXAIPRVV",43,0) .S PXAERR(11)=$G(PXAA("PRIMARY")) "RTN","PXAIPRVV",44,0) .S PXAERR(12)="Another provider has been previously designated as the PRIMARY provider for this patient encounter. "_PXAAX("NAME")_" will be saved as s secondary provider." "RTN","PXAIPRVV",45,0) .S PXAERR(13)="If you whish to change the PRIMARY PROVIDER designation for this encounter, please use one of PCE'S interactive interfaces." "RTN","PXAIPRVV",46,0) ; "RTN","PXAIPRVV",47,0) Q "RTN","PXAPIUTL") 0^6^B833210 "RTN","PXAPIUTL",1,0) PXAPIUTL ;ISL/dee - some of PCE's utilities used by PCE's API ;3/14/97 "RTN","PXAPIUTL",2,0) ;;1.0;PCE PATIENT CARE ENCOUNTER;**27,186**;Aug 12, 1996;Build 3 "RTN","PXAPIUTL",3,0) Q "RTN","PXAPIUTL",4,0) ; "RTN","PXAPIUTL",5,0) SOURCE(X) ;Get IEN of data source in the PCE Data Source file "RTN","PXAPIUTL",6,0) N DIC,Y,DLAYGO "RTN","PXAPIUTL",7,0) S DIC="^PX(839.7," "RTN","PXAPIUTL",8,0) S DLAYGO=839.7 "RTN","PXAPIUTL",9,0) S DIC(0)="LMNOX" "RTN","PXAPIUTL",10,0) D ^DIC "RTN","PXAPIUTL",11,0) Q +Y "RTN","PXAPIUTL",12,0) ; "RTN","PXAPIUTL",13,0) TMPSOURC(X) ;Gets the IEN of the data source the builds the ^TMP("PXK" node for it "RTN","PXAPIUTL",14,0) S ^TMP("PXK",$J,"SOR")=$$SOURCE(X) "RTN","PXAPIUTL",15,0) Q "RTN","PXAPIUTL",16,0) ; "RTN","PXAPIUTL",17,0) PRVCLASS(PROVIDER,VISITDT) ;See if this is a good provider "RTN","PXAPIUTL",18,0) ;Call with a pointer to $VA(200, and a date "RTN","PXAPIUTL",19,0) ; (if no date is passed then it defauts to DT) and returns "RTN","PXAPIUTL",20,0) ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date "RTN","PXAPIUTL",21,0) ; if + of the return is >0 provider is active "RTN","PXAPIUTL",22,0) ; else -1 the provider is not active or bad call "RTN","PXAPIUTL",23,0) ; else -2 if no current person class. "RTN","PXAPIUTL",24,0) ; "RTN","PXAPIUTL",25,0) S:VISITDT="" VISITDT=DT "RTN","PXAPIUTL",26,0) Q:VISITDT<1800000 -1 "RTN","PXAPIUTL",27,0) Q:'$D(^VA(200,+PROVIDER,0)) -1 "RTN","PXAPIUTL",28,0) ; "RTN","PXAPIUTL",29,0) N PXACTIVE "RTN","PXAPIUTL",30,0) S PXACTIVE=$P(^VA(200,PROVIDER,0),"^",11) "RTN","PXAPIUTL",31,0) I PXACTIVE'="",PXACTIVE0 D "RTN","PXBGPRV",39,0) ..S PRIMARY=$S($P(^(IEN),U,4)="P":"PRIMARY",1:"SECONDARY") "RTN","PXBGPRV",40,0) ..S PRVI=+^(IEN),TYPEI=$P(^(IEN),U,6) "RTN","PXBGPRV",41,0) ..S DIC=200,DIC1=DIC,DR=.01,DA=PRVI,DIQ="PRVN" D EN^DIQ1 D "RTN","PXBGPRV",42,0) ...S PRV=PRVN(DIC1,DA,DR) "RTN","PXBGPRV",43,0) ..S FPRI=FPRI_$E(PRIMARY,1,3) ;-Creating Flag for Primary prompt "RTN","PXBGPRV",44,0) ..S TYPE=$$OCCUP("","","",2,TYPEI) D "RTN","PXBGPRV",45,0) ...N Y,DATE "RTN","PXBGPRV",46,0) ...S Y=+$P($G(^AUPNVSIT(VISIT,0)),U) X ^DD("DD") S DATE=$P(Y,"@",1) "RTN","PXBGPRV",47,0) ...I TYPEI="" S TYPE=$$GET^XUA4A72(PRVI,+$P($P($G(^AUPNVSIT(VISIT,0)),U),".")) "RTN","PXBGPRV",48,0) ...I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***" "RTN","PXBGPRV",49,0) ...I +TYPE=-1 S TYPE="" "RTN","PXBGPRV",50,0) ...;I +TYPE>0 S TYPE="**** DELETE and RE-ENTER PROVIDER****" "RTN","PXBGPRV",51,0) ...I +TYPE>0 S TYPE="" "RTN","PXBGPRV",52,0) ..S GROUP=PRV_U_PRIMARY_U_TYPE_U_PRVI "RTN","PXBGPRV",53,0) ..I PRIMARY["PRI" S PRVDR("PRIMARY")=PRV_U_IEN_U_PRVI "RTN","PXBGPRV",54,0) ..S PRV(PRV,IEN)=GROUP "RTN","PXBGPRV",55,0) K ^TMP("PXBU",$J,"PRV") "RTN","PXBGPRV",56,0) ; "RTN","PXBGPRV",57,0) B ;--Add line numbers "RTN","PXBGPRV",58,0) ;create local arrays with data from existing providers "RTN","PXBGPRV",59,0) I $D(PRV) D "RTN","PXBGPRV",60,0) .S PXBC=0,PRV="" F S PRV=$O(PRV(PRV)) Q:PRV="" D "RTN","PXBGPRV",61,0) ..S IEN=0 F S IEN=$O(PRV(PRV,IEN)) Q:IEN="" S PXBC=PXBC+1 D "RTN","PXBGPRV",62,0) ...S PXBKY(PRV,PXBC)=$G(PRV(PRV,IEN)),PXBSAM(PXBC)=$G(PRV(PRV,IEN)) "RTN","PXBGPRV",63,0) ...S PXBSKY(PXBC,IEN)=$P(PRV(PRV,IEN),U,4) "RTN","PXBGPRV",64,0) ...K PRV(PRV,IEN) "RTN","PXBGPRV",65,0) FINISH ;--Finish up some variables "RTN","PXBGPRV",66,0) S:FPRI'["PRI" FPRI=0 S:FPRI["PRI" FPRI=1 "RTN","PXBGPRV",67,0) ;FPRI=0 Then there is no Primary Selected yet "RTN","PXBGPRV",68,0) EXIT ;--set a providers count "RTN","PXBGPRV",69,0) S PXBCNT=+$G(PXBC) "RTN","PXBGPRV",70,0) Q "RTN","PXBGPRV",71,0) ; "RTN","PXBGPRV",72,0) OCCUP(IEN,DATE,CODE,RETURN,CLASSIEN) ;--FORMAT PERSON CLASS TO DISPLAY "RTN","PXBGPRV",73,0) ; IEN = Provider pointer to file# 200 "RTN","PXBGPRV",74,0) ; DATE = Date of occurrence of service "RTN","PXBGPRV",75,0) ; CODE = Person class Code (if already known) "RTN","PXBGPRV",76,0) ; **(Required step) If you use code leave IEN and DATE Blank "RTN","PXBGPRV",77,0) ; RETURN = (Required) Flag to decide what format you want the "RTN","PXBGPRV",78,0) ; return value. "RTN","PXBGPRV",79,0) ; CLASSIEN = Ien of entry in the PERSON CLASS file#8932.1 If the Ien "RTN","PXBGPRV",80,0) ; was saved this parameter could be sent in instead of CODE. "RTN","PXBGPRV",81,0) ; "RTN","PXBGPRV",82,0) ; 1 = IEN^OCCUPATION^SPECIALITY^SUBSPECIALITY^STATUS^DATE INACTIVATED^VA CODE "RTN","PXBGPRV",83,0) ; 2 = Short Description "RTN","PXBGPRV",84,0) ; 3 = Short Description^VA CODE "RTN","PXBGPRV",85,0) ; *** If only CODE and RETURN = 1 There is no value or other "RTN","PXBGPRV",86,0) ; value in the STATUS and DATE INACTIVATED fields. "RTN","PXBGPRV",87,0) ; "RTN","PXBGPRV",88,0) ; Output: "RTN","PXBGPRV",89,0) ; -1 "no comment" function call to person class couldn't find "RTN","PXBGPRV",90,0) ; a class for that person. "RTN","PXBGPRV",91,0) ; -1^COMMENT This function is called incorrectly "RTN","PXBGPRV",92,0) ; -2 "no comment" There is no ACTIVE person class for provider "RTN","PXBGPRV",93,0) ; based on the date provided. "RTN","PXBGPRV",94,0) ; "RTN","PXBGPRV",95,0) N OCC,SPE,SUB,ENTRY,DIS,OCCL,TYPE,VACODE,ANS "RTN","PXBGPRV",96,0) ;--VALIDATE "RTN","PXBGPRV",97,0) I (+$G(IEN)'>0)&($L(IEN)>0) Q -1_"^INVALID PERSON IEN" "RTN","PXBGPRV",98,0) I '$G(IEN),'$G(DATE),$G(CODE)="",'$G(RETURN),'$G(CLASSIEN) Q -1_"^NO PARAMETERS" "RTN","PXBGPRV",99,0) I '$G(IEN),'$G(DATE),$G(CODE)="",$G(RETURN),'$G(CLASSIEN) Q -1_"^NO PARAMETERS" "RTN","PXBGPRV",100,0) I '$G(RETURN) Q -1_"^NO RETURN PARAMETER (Required)" "RTN","PXBGPRV",101,0) I $G(RETURN)]"",(RETURN'<4!(RETURN'>0)) Q -1_"^RETURN MUST BE 1,2,or 3" "RTN","PXBGPRV",102,0) I DATE]"",+DATE'>0 Q -1_"^INVALID FILEMAN DATE" "RTN","PXBGPRV",103,0) I $G(IEN) Q:'$D(^VA(200,$G(IEN))) -1_"^NO SUCH IEN IN FILE# 200" "RTN","PXBGPRV",104,0) I $G(IEN),$G(DATE) D I $G(RETURN)=1 Q TYPE "RTN","PXBGPRV",105,0) .S TYPE=$$GET^XUA4A72(IEN,$P(DATE,".")),VACODE=$P(TYPE,U,7) "RTN","PXBGPRV",106,0) I $G(IEN),$G(DATE),+TYPE<0 Q TYPE "RTN","PXBGPRV",107,0) ; "RTN","PXBGPRV",108,0) ;---CONVERT IEN TO CODE "RTN","PXBGPRV",109,0) I $G(CLASSIEN) S CODE=$$IEN2CODE^XUA4A72(CLASSIEN) "RTN","PXBGPRV",110,0) ; "RTN","PXBGPRV",111,0) I $G(CODE)]"",'$G(IEN),'$G(DATE) S TYPE=$O(^USC(8932.1,"F",$G(CODE),0)),VACODE=CODE I $G(RETURN)=1 S ANS=TYPE_U_$G(^USC(8932.1,TYPE,0)) Q ANS "RTN","PXBGPRV",112,0) S ENTRY=$G(^USC(8932.1,+TYPE,0)) "RTN","PXBGPRV",113,0) OCC ;---OCCUPATION "RTN","PXBGPRV",114,0) S OCCL=$P(ENTRY,U) "RTN","PXBGPRV",115,0) S OCC=$P($P(ENTRY,U)," ",1) "RTN","PXBGPRV",116,0) I OCCL["Physicians (M.D" S OCC="Physician" "RTN","PXBGPRV",117,0) I OCCL["Physician Assistant" S OCC=OCCL "RTN","PXBGPRV",118,0) I OCCL["Speech, Language" S OCC="Language" "RTN","PXBGPRV",119,0) I OCCL["Technologists" S OCC="Technical" "RTN","PXBGPRV",120,0) I OCCL["Eye and Vision" S OCC="Ophthalmic" "RTN","PXBGPRV",121,0) I OCCL["Respiratory, Rehab" S OCC="Therapist" "RTN","PXBGPRV",122,0) I OCCL["Podiatric" S OCC="Podiatry" "RTN","PXBGPRV",123,0) ; "RTN","PXBGPRV",124,0) SPE ;--SPECIALITY "RTN","PXBGPRV",125,0) S SPEL=$P(ENTRY,U,2) "RTN","PXBGPRV",126,0) S SPE=$P(ENTRY,U,2) "RTN","PXBGPRV",127,0) I SPEL["Registered Nurse" S SPE="R.N." "RTN","PXBGPRV",128,0) I SPEL["Dentist" S SPE="Dentist" "RTN","PXBGPRV",129,0) I SPEL["Clinical Services" S SPE="Clinical" "RTN","PXBGPRV",130,0) I SPEL["Non-R.N.s" S SPE="Non R.N." "RTN","PXBGPRV",131,0) I SPEL["Radiologic Sciences" S SPE="Radiology" "RTN","PXBGPRV",132,0) I SPEL["Clinical Path" S SPE="" "RTN","PXBGPRV",133,0) I SPEL["Physical Therap" S SPE="P.T." "RTN","PXBGPRV",134,0) I SPEL["Obstetrics and Gynecology" S SPE="Ob. & Gyn." "RTN","PXBGPRV",135,0) I SPEL["iatry and Neur" S SPE="Psyc & Neuro" "RTN","PXBGPRV",136,0) I SPEL["Clinical Specialist" S SPE="Clinical" "RTN","PXBGPRV",137,0) I SPEL["Registered Dietitian" S SPE="R. Dietitian" "RTN","PXBGPRV",138,0) I SPEL["Rehabilitation Prac" S SPE="Rehabilitation" "RTN","PXBGPRV",139,0) I OCC["Physician"&(SPE["Internal Medicine") S SPE="Internist" "RTN","PXBGPRV",140,0) ; "RTN","PXBGPRV",141,0) SUB ;--SUBSPECIALITY "RTN","PXBGPRV",142,0) S SUBL=$P(ENTRY,U,3) "RTN","PXBGPRV",143,0) S SUB=$P(ENTRY,U,3) "RTN","PXBGPRV",144,0) I SUB["Counselor"&(SPE["Counselor") S SPE="" "RTN","PXBGPRV",145,0) I SUB["Therapist"&(SPE["Therapist") S SPE="" "RTN","PXBGPRV",146,0) I SUB["Nurse"&(SPE["Nurse") S SPE="" "RTN","PXBGPRV",147,0) I SUB["Pediatric"&(SPE["Pediatric") S SPE="" "RTN","PXBGPRV",148,0) I SUB["Psychiatry"&(SPE["Psychiatry") S SPE="" "RTN","PXBGPRV",149,0) I SUB["Podiatri"&(SPE["Podiatri") S SPE="" "RTN","PXBGPRV",150,0) I SUB["Clinical and Laboratory Immunology" S SUB="Clin & Lab Immunology" "RTN","PXBGPRV",151,0) I SUB["Clinical & Laboratory Immunology" S SUB="Clin & Lab Immunology" "RTN","PXBGPRV",152,0) I SUB["cine-Envir" S SUB="Occ & Environmental" "RTN","PXBGPRV",153,0) I SUB["Child and Adolescent Psyc" S SUB="Pediatric Mental Health" "RTN","PXBGPRV",154,0) I SUB["ist in Meta" S SUB="Metabolic" "RTN","PXBGPRV",155,0) I SUB["ist in Pedia" S SUB="Pediatric" "RTN","PXBGPRV",156,0) I SUB["ist in Renal" S SUB="Renal" "RTN","PXBGPRV",157,0) I SUB["tion Intern" S SUB="Intern" "RTN","PXBGPRV",158,0) I SUB["tion Coordin" S SUB="Coordinator" "RTN","PXBGPRV",159,0) I SUB["tion Counselor" S SUB="Counselor" "RTN","PXBGPRV",160,0) I SUB["for the Blind" S SUB="Orientation for Blind" "RTN","PXBGPRV",161,0) I SUB["Dosimetrist" S SUB="Planning, Dosimetrist" "RTN","PXBGPRV",162,0) I SPEL["Respiratory Care Pr"&(SUB'="") S SPE="" "RTN","PXBGPRV",163,0) ; "RTN","PXBGPRV",164,0) ;--CALCULATE THE BEST DISPLAY "RTN","PXBGPRV",165,0) S DISL=OCCL_"-"_SPEL_"-"_SUBL "RTN","PXBGPRV",166,0) S DIS=OCC_"/"_SPE_"/"_SUB "RTN","PXBGPRV",167,0) I SUB[SPE S DIS=OCC_"/"_SUB "RTN","PXBGPRV",168,0) I SPE="" S DIS=OCC_"/"_SUB "RTN","PXBGPRV",169,0) I SUB="" S DIS=OCC_"/"_SPE "RTN","PXBGPRV",170,0) AND I $L(DIS," and ")>1 D "RTN","PXBGPRV",171,0) .N I F I=1:1:$L(DIS," ") I $P(DIS," ",I)="and" S $P(DIS," ",I)="&" "RTN","PXBGPRV",172,0) I $L(DIS," and ")>1 G AND "RTN","PXBGPRV",173,0) ;Q $E(DIS,1,40)_" "_$L(DIS) "RTN","PXBGPRV",174,0) ;Q $E(DIS,1,40)_"***"_OCCL "RTN","PXBGPRV",175,0) ;Q SPE_" *** "_SPEL "RTN","PXBGPRV",176,0) ;Q SUB_" *** "_SUBL "RTN","PXBGPRV",177,0) ;Q DISL_"~"_DIS "RTN","PXBGPRV",178,0) ;Q ""_"~"_DIS "RTN","PXBGPRV",179,0) I $G(RETURN)=2 Q DIS "RTN","PXBGPRV",180,0) I $G(RETURN)=3 Q DIS_U_VACODE "RTN","PXBGPRV",181,0) Q -1_"^SOMETHING BAD WRONG_SHOULDN'T BE HERE" "RTN","PXBGPRV2") 0^8^B43180036 "RTN","PXBGPRV2",1,0) PXBGPRV2 ;ISL/JVS - DOUBLE ?? GATHERING OF PROVIDER ; 7/12/07 10:38am "RTN","PXBGPRV2",2,0) ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,11,19,105,186**;Aug 12, 1996;Build 3 "RTN","PXBGPRV2",3,0) ; "RTN","PXBGPRV2",4,0) ; "RTN","PXBGPRV2",5,0) ; "RTN","PXBGPRV2",6,0) W !,"THIS IS NOT AN ENTRY POINT" Q "RTN","PXBGPRV2",7,0) ; "RTN","PXBGPRV2",8,0) DOUBLE(FROM) ;--Entry point "RTN","PXBGPRV2",9,0) ; "RTN","PXBGPRV2",10,0) ; WHAT = The same WHAT as sent in from the API "RTN","PXBGPRV2",11,0) ; FROM = Exactly which prompt is asking for the list "RTN","PXBGPRV2",12,0) ; SCREEN = Same as the DIC("S") screen used by file man "RTN","PXBGPRV2",13,0) ; START = The starting point as to what to look up "RTN","PXBGPRV2",14,0) ; "RTN","PXBGPRV2",15,0) N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,BACK,NUM,TEMP "RTN","PXBGPRV2",16,0) ; "RTN","PXBGPRV2",17,0) S BACK="",NUM=0,SCREEN="" "RTN","PXBGPRV2",18,0) D LOC "RTN","PXBGPRV2",19,0) I $D(DIC("S")) S SCREEN=DIC("S") "RTN","PXBGPRV2",20,0) ; "RTN","PXBGPRV2",21,0) START ;--RECYCLE POINT "RTN","PXBGPRV2",22,0) ; "RTN","PXBGPRV2",23,0) S TITLE="- - A L L P R O V I D E R S - -" "RTN","PXBGPRV2",24,0) ; "RTN","PXBGPRV2",25,0) D SETUP "RTN","PXBGPRV2",26,0) ; "RTN","PXBGPRV2",27,0) ; begin patch *186* "RTN","PXBGPRV2",28,0) S:$G(SCREEN)="" SCREEN="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))" "RTN","PXBGPRV2",29,0) ;D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","","","","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)") "RTN","PXBGPRV2",30,0) D LIST^DIC(FILE,"",FIELD,BACK,10,.START,"","",SCREEN,"","^TMP(""PXBTANA"",$J)","^TMP(""PXBTANA"",$J)") "RTN","PXBGPRV2",31,0) ; end patch *186* "RTN","PXBGPRV2",32,0) ; "RTN","PXBGPRV2",33,0) D LOC,HEAD,SUB "RTN","PXBGPRV2",34,0) ; "RTN","PXBGPRV2",35,0) PROMPT ;---WRITE PROMPT HERE "RTN","PXBGPRV2",36,0) D WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1) "RTN","PXBGPRV2",37,0) I $G(START)'="" W !!,"Enter '^' to quit, '-' for previous page." "RTN","PXBGPRV2",38,0) I $G(START)'="" S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: " "RTN","PXBGPRV2",39,0) I $G(START)="" S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: " "RTN","PXBGPRV2",40,0) S DIR("?")="Enter ITEM 'No' to select , '^' to quit, '-' for previous page." "RTN","PXBGPRV2",41,0) S DIR(0)="N,A,O^0:10:0^I X'?.1""-"".1""^"".2N!(+X>10) K X" "RTN","PXBGPRV2",42,0) D ^DIR "RTN","PXBGPRV2",43,0) I X="",$G(START)="" S X="^",DIRUT=1 "RTN","PXBGPRV2",44,0) I X="-" S BACK="B" D BACK G START "RTN","PXBGPRV2",45,0) I X="" S BACK="" D FORWARD G START "RTN","PXBGPRV2",46,0) I $G(DIRUT) K DIRUT S VAL="^P" G EXIT "RTN","PXBGPRV2",47,0) FINISH ;--FINISH SETTING A VARIBLE TO SELECTED ITEM "RTN","PXBGPRV2",48,0) ; "RTN","PXBGPRV2",49,0) S VAL=$G(^TMP("PXBTANA",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTANA",$J,"DILIST","ID",X,.01)) "RTN","PXBGPRV2",50,0) EXIT ;--EXIT "RTN","PXBGPRV2",51,0) K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J) "RTN","PXBGPRV2",52,0) Q VAL "RTN","PXBGPRV2",53,0) ; "RTN","PXBGPRV2",54,0) DOUBLE1(FROM) ;--Entry point "RTN","PXBGPRV2",55,0) ; "RTN","PXBGPRV2",56,0) NEW ; "RTN","PXBGPRV2",57,0) ; "RTN","PXBGPRV2",58,0) N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE "RTN","PXBGPRV2",59,0) N TOTAL,TEMP,SUB2,VANUMBER,PXBVA "RTN","PXBGPRV2",60,0) ;---SETUP VARIABLES "RTN","PXBGPRV2",61,0) ; begin patch *186* "RTN","PXBGPRV2",62,0) ; S BACK="",INDEX="",TOTAL1=0 "RTN","PXBGPRV2",63,0) S BACK="",INDEX="",TOTAL=0 "RTN","PXBGPRV2",64,0) ; end patch *186* "RTN","PXBGPRV2",65,0) S START=DATA,SUB=0,SUB2=0 "RTN","PXBGPRV2",66,0) ; "RTN","PXBGPRV2",67,0) START1 ;--RECYCLE POINT "RTN","PXBGPRV2",68,0) S TITLE="- - S E L E C T E D P R O V I D E R S - -" "RTN","PXBGPRV2",69,0) S FILE=200 "RTN","PXBGPRV2",70,0) S FIELD="@;.01" ; FIELD=.01 TEJ *105 CHANGE PARM 12/14/2000 "RTN","PXBGPRV2",71,0) RELOOK ;----ADJUST THE DATA FOR LOOKUP IF NECESSARY "RTN","PXBGPRV2",72,0) I DATA?.AP S START=$O(^VA(200,"B",DATA),-1) "RTN","PXBGPRV2",73,0) I DATA?1AP S DATA="*" "RTN","PXBGPRV2",74,0) I DATA?1A4N S START=$O(^VA(200,"BS5",DATA),-1) S INDEX="BS5" "RTN","PXBGPRV2",75,0) ;---------------- "RTN","PXBGPRV2",76,0) ; begin patch *186* "RTN","PXBGPRV2",77,0) ;S SCREEN="" "RTN","PXBGPRV2",78,0) S SCREEN="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))" "RTN","PXBGPRV2",79,0) ; end patch *186* "RTN","PXBGPRV2",80,0) ; "RTN","PXBGPRV2",81,0) D LIST^DIC(FILE,"",FIELD,BACK,"",.START,DATA,INDEX,SCREEN,"","^TMP(""PXBTOTAL"",$J)","^TMP(""PXBTOTAL"",$J)") "RTN","PXBGPRV2",82,0) S TOTAL=$P(^TMP("PXBTOTAL",$J,"DILIST",0),"^",1) "RTN","PXBGPRV2",83,0) ;-------------VA NUMBER------------------ "RTN","PXBGPRV2",84,0) S PXBVA=0 F S PXBVA=$O(^TMP("PXBTOTAL",$J,"DILIST",2,PXBVA)) Q:PXBVA="" S VANUMBER($G(^TMP("PXBTOTAL",$J,"DILIST",2,PXBVA)))="" "RTN","PXBGPRV2",85,0) S START=$O(^VA(200,"PS2",DATA),-1) "RTN","PXBGPRV2",86,0) I DATA=+DATA S START=DATA_" " "RTN","PXBGPRV2",87,0) F S START=$O(^VA(200,"PS2",START)) Q:START'[DATA D "RTN","PXBGPRV2",88,0) .Q:$D(VANUMBER($O(^VA(200,"PS2",START,0)))) "RTN","PXBGPRV2",89,0) .N IEN "RTN","PXBGPRV2",90,0) .S TOTAL=TOTAL+1 "RTN","PXBGPRV2",91,0) .S (IEN,^TMP("PXBTOTAL",$J,"DILIST",2,TOTAL))=$O(^VA(200,"PS2",START,0)) "RTN","PXBGPRV2",92,0) .S ^TMP("PXBTOTAL",$J,"DILIST","ID",TOTAL,.01)=$P($G(^VA(200,IEN,0)),"^",1) "RTN","PXBGPRV2",93,0) ;----------END VA NUMBERS----------------- "RTN","PXBGPRV2",94,0) ; "RTN","PXBGPRV2",95,0) ;--DISPLAY IF NO MATCH FOUND "RTN","PXBGPRV2",96,0) I TOTAL=0 D "RTN","PXBGPRV2",97,0) .D WIN17^PXBCC(PXBCNT) "RTN","PXBGPRV2",98,0) .I DATA?1AP W ! D HELP^PXBUTL0("CPT4") "RTN","PXBGPRV2",99,0) .I DATA'?1AP W ! D HELP^PXBUTL0("PRVM") "RTN","PXBGPRV2",100,0) .S ERROR=1,CYCL=1 "RTN","PXBGPRV2",101,0) I TOTAL=0 Q TOTAL "RTN","PXBGPRV2",102,0) ; "RTN","PXBGPRV2",103,0) ; "RTN","PXBGPRV2",104,0) ;----DISPLAY LIST TO THE SCREEN "RTN","PXBGPRV2",105,0) S HEADING="W !,""ITEM"",?6,""NAME"",?30,""PERSON CLASS IN NEW PERSON FILE""" "RTN","PXBGPRV2",106,0) LIST ;-DISPLAY LIST TO THE SCREEN "RTN","PXBGPRV2",107,0) ;---NEW CODE PATCH 11 "RTN","PXBGPRV2",108,0) N PXBTYPE "RTN","PXBGPRV2",109,0) I TOTAL=1 D I PXBTYPE>0 S X=1 G VAL "RTN","PXBGPRV2",110,0) .S PXBTYPE=$$GET^XUA4A72($G(^TMP("PXBTOTAL",$J,"DILIST",2,1)),+$P($P($G(^AUPNVSIT(PXBVST,0)),U),".")) "RTN","PXBGPRV2",111,0) ;-----END NEW CODE--- "RTN","PXBGPRV2",112,0) ;I TOTAL=1 S X=1 G VAL "RTN","PXBGPRV2",113,0) D LOC W ! "RTN","PXBGPRV2",114,0) X HEADING "RTN","PXBGPRV2",115,0) S SUB=SUB-1 "RTN","PXBGPRV2",116,0) S NUM=0 F S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) S NUM=NUM+1 Q:NUM=11 Q:SUB'>0 S SUB2=SUB2+1 D "RTN","PXBGPRV2",117,0) .;---CHANGED "RTN","PXBGPRV2",118,0) .N NAME,TYPE "RTN","PXBGPRV2",119,0) .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01)) "RTN","PXBGPRV2",120,0) .S TYPE=$$OCCUP^PXBGPRV($G(^TMP("PXBTOTAL",$J,"DILIST",2,SUB)),+$P($G(^AUPNVSIT(PXBVST,0)),"^",1),"",2) D "RTN","PXBGPRV2",121,0) ..N Y,DATE "RTN","PXBGPRV2",122,0) ..S Y=+$P($G(^AUPNVSIT(PXBVST,0)),"^",1) X ^DD("DD") S DATE=$P(Y,"@",1) "RTN","PXBGPRV2",123,0) ..I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***" "RTN","PXBGPRV2",124,0) ..I +TYPE=-1 S TYPE="" "RTN","PXBGPRV2",125,0) .W !,SUB,?6,$E(NAME,1,20),?30,$E(TYPE,1,45) "RTN","PXBGPRV2",126,0) ;---------- "RTN","PXBGPRV2",127,0) ; "RTN","PXBGPRV2",128,0) ;----If There is only one selection go to proper prompting "RTN","PXBGPRV2",129,0) I TOTAL=1 G PRMPT2 "RTN","PXBGPRV2",130,0) ; "RTN","PXBGPRV2",131,0) PRMPT ;---WRITE PROMPT HERE "RTN","PXBGPRV2",132,0) D WIN17^PXBCC(PXBCNT) "RTN","PXBGPRV2",133,0) D LOC^PXBCC(15,1) "RTN","PXBGPRV2",134,0) W ! "RTN","PXBGPRV2",135,0) I SUB>0 W !,"Enter '^' to quit" "RTN","PXBGPRV2",136,0) E I TOTAL>10 W !," END OF LIST" "RTN","PXBGPRV2",137,0) I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: " "RTN","PXBGPRV2",138,0) E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: " "RTN","PXBGPRV2",139,0) S DIR("?")="Enter ITEM 'No' to select , '^' to quit" "RTN","PXBGPRV2",140,0) S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X" "RTN","PXBGPRV2",141,0) D ^DIR "RTN","PXBGPRV2",142,0) I X="",SUB>0 G LIST "RTN","PXBGPRV2",143,0) I X="",SUB'>0 S X="^" "RTN","PXBGPRV2",144,0) VAL ;-----Set the VAL equal to the value "RTN","PXBGPRV2",145,0) S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01)) "RTN","PXBGPRV2",146,0) I FROM="PL",TOTAL=1 W $G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01)) "RTN","PXBGPRV2",147,0) EXITNEW ;--EXIT "RTN","PXBGPRV2",148,0) K DIR,^TMP("PXBTOTAL",$J),^TMP("PXBTANA",$J) "RTN","PXBGPRV2",149,0) K TANA,TOTAL "RTN","PXBGPRV2",150,0) Q VAL "RTN","PXBGPRV2",151,0) Q "RTN","PXBGPRV2",152,0) ; "RTN","PXBGPRV2",153,0) ;-----------------SUBROUTINES-------------- "RTN","PXBGPRV2",154,0) BACK ; "RTN","PXBGPRV2",155,0) S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1)) "RTN","PXBGPRV2",156,0) S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1)) "RTN","PXBGPRV2",157,0) Q "RTN","PXBGPRV2",158,0) FORWARD ; "RTN","PXBGPRV2",159,0) S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10)) "RTN","PXBGPRV2",160,0) S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10)) "RTN","PXBGPRV2",161,0) Q "RTN","PXBGPRV2",162,0) LOC ;--LOCATE CURSOR "RTN","PXBGPRV2",163,0) D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR "RTN","PXBGPRV2",164,0) W IOEDEOP ;--CLEAR THE PAGE "RTN","PXBGPRV2",165,0) Q "RTN","PXBGPRV2",166,0) HEAD ;--HEAD "RTN","PXBGPRV2",167,0) W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL "RTN","PXBGPRV2",168,0) Q "RTN","PXBGPRV2",169,0) SUB ;--DISPLAY LIST TO THE SCREEN "RTN","PXBGPRV2",170,0) N TYPE "RTN","PXBGPRV2",171,0) I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!," E N D O F L I S T" Q "RTN","PXBGPRV2",172,0) X HEADING "RTN","PXBGPRV2",173,0) S SUB=0,CNT=0 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D "RTN","PXBGPRV2",174,0) .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01)) "RTN","PXBGPRV2",175,0) .S TYPE=$$OCCUP^PXBGPRV($G(^TMP("PXBTANA",$J,"DILIST",2,SUB)),+$P($G(^AUPNVSIT(PXBVST,0)),"^",1),"",2) D "RTN","PXBGPRV2",176,0) ..N Y,DATE "RTN","PXBGPRV2",177,0) ..S Y=+$P($G(^AUPNVSIT(PXBVST,0)),"^",1) X ^DD("DD") S DATE=$P(Y,"@",1) "RTN","PXBGPRV2",178,0) ..I +TYPE=-2 S TYPE="*** CLASS not 'ACTIVE' on "_DATE_"***" "RTN","PXBGPRV2",179,0) ..I +TYPE=-1 S TYPE="" "RTN","PXBGPRV2",180,0) .W !,SUB,?6,$E(NAME,1,20),?30,$E(TYPE,1,45) "RTN","PXBGPRV2",181,0) Q "RTN","PXBGPRV2",182,0) SETUP ;-SETP VARIABLES "RTN","PXBGPRV2",183,0) S FILE=200,FIELD="@;.01" ; FIELD=.01 TEJ *105 CHANGE PARM 12/14/2000 "RTN","PXBGPRV2",184,0) S HEADING="W !,""ITEM"",?6,""NAME"",?30,""PERSON CLASS IN NEW PERSON FILE""" "RTN","PXBGPRV2",185,0) Q "RTN","PXBGPRV2",186,0) PRMPT2 ;-----Yes and No prompt if onlyi choice "RTN","PXBGPRV2",187,0) D WIN17^PXBCC(PXBCNT) "RTN","PXBGPRV2",188,0) D LOC^PXBCC(15,1) "RTN","PXBGPRV2",189,0) S DIR("A")="Is this the correct entry " "RTN","PXBGPRV2",190,0) S DIR("B")="YES" "RTN","PXBGPRV2",191,0) S DIR(0)="Y" "RTN","PXBGPRV2",192,0) D ^DIR "RTN","PXBGPRV2",193,0) I Y=0 S X="^" "RTN","PXBGPRV2",194,0) I Y=1 S X=1 "RTN","PXBGPRV2",195,0) G VAL "RTN","PXBPORD") 0^2^B3025931 "RTN","PXBPORD",1,0) PXBPORD ;ISL/JVS - PROMPT ORDERING PROVIDER ; 6/27/07 6:45pm "RTN","PXBPORD",2,0) ;;1.0;PCE PATIENT CARE ENCOUNTER;**124,186**;Aug 12, 1996;Build 3 "RTN","PXBPORD",3,0) ; "RTN","PXBPORD",4,0) ORD ;--Ordering Provider "RTN","PXBPORD",5,0) N TIMED,DATA,DIC,X,Y,CPTORD "RTN","PXBPORD",6,0) S CPTORD=$S($P(REQI,U,22):$P(^VA(200,$P(REQI,U,22),0),U,1),1:"") "RTN","PXBPORD",7,0) S TIMED="I '$T!(DATA[""^"")" "RTN","PXBPORD",8,0) D WIN17^PXBCC(PXBCNT),LOC^PXBCC(16,0) "RTN","PXBPORD",9,0) W IOSC,IOEDEOP "RTN","PXBPORD",10,0) O ;--SECOND ENTRY POINT "RTN","PXBPORD",11,0) ; begin patch *186* "RTN","PXBPORD",12,0) ;W IORC," Enter Ordering Provider: "_$G(CPTORD)_"//",IOELEOL "RTN","PXBPORD",13,0) W IORC," Enter Ordering Provider: "_$G(CPTORD)_" // " "RTN","PXBPORD",14,0) W IOSC,IOELEOL "RTN","PXBPORD",15,0) ; end patch *186* "RTN","PXBPORD",16,0) R DATA:DTIME "RTN","PXBPORD",17,0) O1 ;--- "RTN","PXBPORD",18,0) X TIMED I G ORDX "RTN","PXBPORD",19,0) I DATA="@" S $P(REQI,"^",22)="@" G ORDX "RTN","PXBPORD",20,0) I DATA="^"!(DATA="^^")!(DATA["^O") G ORDX "RTN","PXBPORD",21,0) ;I DATA="?" D EN1^PXBHLP0("PXB","ORD",1,"",1) G O "RTN","PXBPORD",22,0) ;I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","ORD","",1,2) S:DATA="O" UDATA="^O" S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P(DATA,"^",2) S:$G(UDATA)="" UDATA="^O" S:UDATA="^O" (DATA,EDATA,Y)=UDATA G:UDATA="^O" O1 "RTN","PXBPORD",23,0) I DATA="?" D HELP^PXBUTL0("OP1") G O "RTN","PXBPORD",24,0) I DATA="??" D HELP^PXBUTL0("OP2") G O "RTN","PXBPORD",25,0) I DATA="",$G(CPTORD)'="" S DATA=CPTORD "RTN","PXBPORD",26,0) I DATA="" G ORDX "RTN","PXBPORD",27,0) D CASE^PXBUTL "RTN","PXBPORD",28,0) ;----SPACE BAR--- "RTN","PXBPORD",29,0) I DATA'=" ",DATA'["^",DATA'="" S ^DISV(DUZ,"PXBORD-22")=DATA "RTN","PXBPORD",30,0) I DATA=" ",$D(^DISV(DUZ,"PXBORD-22")) S DATA=^DISV(DUZ,"PXBORD-22") W DATA "RTN","PXBPORD",31,0) ;--If a "?" is NOT entered during lookup "RTN","PXBPORD",32,0) ; begin patch *186* "RTN","PXBPORD",33,0) ; S X=DATA,DIC=200,DIC(0)="OQME" D ^DIC "RTN","PXBPORD",34,0) ; I Y=-1 S $P(REQE,U,22)="" G ORDX "RTN","PXBPORD",35,0) S DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))" "RTN","PXBPORD",36,0) S X=DATA,DIC=200,DIC(0)="OQME" D ^DIC "RTN","PXBPORD",37,0) I +Y>0 D "RTN","PXBPORD",38,0) . W IORC W:$G(CPTORD)'=X X W IOEDEOP "RTN","PXBPORD",39,0) E D G O "RTN","PXBPORD",40,0) . N EDATA S EDATA=X "RTN","PXBPORD",41,0) . D LOC^PXBCC(16,0),HELP^PXBUTL0("PRVM") "RTN","PXBPORD",42,0) . D HELP1^PXBUTL1("CON") R X:DTIME "RTN","PXBPORD",43,0) . D LOC^PXBCC(16,0) W IOSC,IOEDEOP "RTN","PXBPORD",44,0) ; end patch *186* "RTN","PXBPORD",45,0) ; "RTN","PXBPORD",46,0) S $P(REQI,U,22)=+Y,$P(REQE,U,22)=$P(Y,U,2) "RTN","PXBPORD",47,0) ORDX ;--EXIT AND CLEANUP "RTN","PXBPORD",48,0) I '$D(REQE) S REQE="" "RTN","PXBPORD",49,0) I $P(REQE,U,22)="" S $P(REQI,U,22)="" "RTN","PXBPORD",50,0) Q "RTN","PXBPPRV") 0^3^B43404885 "RTN","PXBPPRV",1,0) PXBPPRV ;ISL/JVS,ESW - PROMPT PROVIDER ; 7/12/07 11:14am "RTN","PXBPPRV",2,0) ;;1.0;PCE PATIENT CARE ENCOUNTER;**1,7,11,19,108,141,152,186**;Aug 12, 1996;Build 3 "RTN","PXBPPRV",3,0) ; "RTN","PXBPPRV",4,0) ; VARIABLE LIST "RTN","PXBPPRV",5,0) ; SELINE= Line number of selected item "RTN","PXBPPRV",6,0) ; "RTN","PXBPPRV",7,0) PRV ;--PROVIDER "RTN","PXBPPRV",8,0) I $D(PXBUT),$G(PXBUT) S PXBUT=0 ; patch *186* "RTN","PXBPPRV",9,0) I $D(PXBNPRVL) W IOSC D LOC^PXBCC(2,0) W IOUON,"Previous Entry: ",$G(PXBNPRVL(1)) F I=1:1:10 W " " "RTN","PXBPPRV",10,0) I $D(PXBNPRVL) W IORC "RTN","PXBPPRV",11,0) W IOUOFF "RTN","PXBPPRV",12,0) N TIMED,EDATA,DIC,LINE,XFLAG,SELINE,UDATA,ECHO "RTN","PXBPPRV",13,0) I '$D(^DISV(DUZ,"PXBPRV-4")) S ^DISV(DUZ,"PXBPRV-4")=" " "RTN","PXBPPRV",14,0) I '$D(IOSC) D TERM^PXBCC "RTN","PXBPPRV",15,0) S DOUBLEQQ=0 "RTN","PXBPPRV",16,0) S TIMED="I '$T!(DATA=""^"")" "RTN","PXBPPRV",17,0) P ;--Second Entry point "RTN","PXBPPRV",18,0) W IOSC "RTN","PXBPPRV",19,0) ;--DYNAMIC HEADER-- "RTN","PXBPPRV",20,0) I '$D(CYCL) D "RTN","PXBPPRV",21,0) .I PXBCNT=0,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" PROVIDER(S) associated with this encounter." "RTN","PXBPPRV",22,0) .I PXBCNT=1,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There is "_$G(PXBCNT)_" PROVIDER associated with this encounter." "RTN","PXBPPRV",23,0) .I PXBCNT>1,DOUBLEQQ=0,$G(WHAT)'["PRV" D LOC^PXBCC(1,10) W "...There are "_$G(PXBCNT)_" PROVIDERS associated with this encounter." "RTN","PXBPPRV",24,0) ; "RTN","PXBPPRV",25,0) I $G(FROM)'="PL" D LOC^PXBCC(15,0) "RTN","PXBPPRV",26,0) I $G(FROM)'["PRV" N PXBNPRVL "RTN","PXBPPRV",27,0) I $D(FROM),FROM="PL" W IORC "RTN","PXBPPRV",28,0) I $G(FROM)'="PL",PXBCNT>10&('$G(DOUBLEQQ)) W IOELEOL,!,"Enter '+' for next page, '-' for previous page." "RTN","PXBPPRV",29,0) ;--Dynamic prompting for the provider-- "RTN","PXBPPRV",30,0) I '$D(^TMP("PXK",$J,"PRV")),'$D(FROM) W !,"Enter PROVIDER: " W IOELEOL "RTN","PXBPPRV",31,0) I '$D(FROM),$D(^TMP("PXK",$J,"PRV")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROVIDER: " W IOELEOL "RTN","PXBPPRV",32,0) I $D(FROM),FROM="CPT",'$D(^TMP("PXK",$J,"PRV")) W IORC,!,"Enter PROVIDER associated with PROCEDURE: " W IOELEOL "RTN","PXBPPRV",33,0) I $D(FROM),FROM="PRV" W !,"Enter PROVIDER: " W IOELEOL "RTN","PXBPPRV",34,0) I $D(FROM),FROM="CPT",$D(^TMP("PXK",$J,"PRV")) W IORC,!,"Enter PROVIDER associated with PROCEDURES: " W IOELEOL "RTN","PXBPPRV",35,0) I $D(FROM),FROM="PL" W !,"Enter PROVIDER associated with PROBLEM: " W IOELEOL "RTN","PXBPPRV",36,0) I $D(FROM),FROM="PL" S PXBDPRV="^"_$P($G(PRVDR("PRIMARY")),U) ;;108 "RTN","PXBPPRV",37,0) ;I $D(PRVDR) S PXBDPRV="^"_$P(PRVDR("PRIMARY"),U) S:$G(PXBCNT)>1&($P($G(REQE),U)=0) D0=$P($G(PRVDR("PRIMARY")),U,3) "RTN","PXBPPRV",38,0) I $D(PRVDR) S PXBDPRV="^"_$P(PRVDR("PRIMARY"),U),D0=$P($G(PRVDR("PRIMARY")),U,3) "RTN","PXBPPRV",39,0) I $D(FROM),FROM="CPT",$P(REQI,U,1),$P(REQE,U,1)'["..." S $P(PXBDPRV,U,2)=$P(REQE,U,1) "RTN","PXBPPRV",40,0) I $P($G(REQI),U,8)'="",$G(FROM)'="CPT" S D0=$P($G(^AUPNVCPT($P(REQI,U,8),12)),U,4),PXBDPRV="^"_$P(REQE,U) "RTN","PXBPPRV",41,0) ; begin patch *186* "RTN","PXBPPRV",42,0) ; W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV) " // ",IOELEOL "RTN","PXBPPRV",43,0) W $P($G(PXBDPRV),"^",2) W:$D(PXBDPRV)&($G(PXBDPRV)'="^") " // ",IOELEOL "RTN","PXBPPRV",44,0) ; end patch *186* "RTN","PXBPPRV",45,0) ; "RTN","PXBPPRV",46,0) R DATA:DTIME S (EDATA,ECHO)=DATA "RTN","PXBPPRV",47,0) P1 ;--Third entry point "RTN","PXBPPRV",48,0) X TIMED I S PXBUT=1 S:DATA="^" LEAVE=1 G PRVX "RTN","PXBPPRV",49,0) I DATA?1.N1"E".NAP S DATA=" "_DATA "RTN","PXBPPRV",50,0) I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199) "RTN","PXBPPRV",51,0) I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24) "RTN","PXBPPRV",52,0) D CASE^PXBUTL "RTN","PXBPPRV",53,0) ;---SPACE BAR "RTN","PXBPPRV",54,0) I DATA=" ",$D(^DISV(DUZ,"PXBPRV-4")) S (DATA,EDATA)=^DISV(DUZ,"PXBPRV-4") W DATA "RTN","PXBPPRV",55,0) ;----------- "RTN","PXBPPRV",56,0) I DATA="^^" S PXBEXIT=0 G PRVX "RTN","PXBPPRV",57,0) ;---I Prompt can jump to others put symbols in here "RTN","PXBPPRV",58,0) I DATA["^P" G PRVX "RTN","PXBPPRV",59,0) I DATA["^I" G PRVX "RTN","PXBPPRV",60,0) ; PX*1.0*152 - need to flag if default has been chosen. PXBDPRV gets killed so can't be used as flag. "RTN","PXBPPRV",61,0) N PXDEF152 S PXDEF152=0 "RTN","PXBPPRV",62,0) I DATA="",$D(PXBDPRV) S DATA=$P($G(PXBDPRV),"^",2),PXDEF152=1 I DATA="" S PXBUT=1 G PRVX "RTN","PXBPPRV",63,0) I DATA="",'$D(PXBDPRV) S PXBUT=1 G PRVX "RTN","PXBPPRV",64,0) ; "RTN","PXBPPRV",65,0) I PXBCNT>10&((DATA="+")!(DATA="-")) D DPRV4^PXBDPRV(DATA) W IORC D WIN17^PXBCC(PXBCNT) G P "RTN","PXBPPRV",66,0) ; "RTN","PXBPPRV",67,0) K PRVN1 S VIEN=0 F I=1:1 S VIEN=$O(PXBSAM(VIEN)) Q:VIEN="" S PRVN1=PXBSAM(VIEN),PRVN1($P(PRVN1,U,4))=PRVN1_"^"_VIEN "RTN","PXBPPRV",68,0) M ;--IF Multiple entries have been entered "RTN","PXBPPRV",69,0) ;--CAN'T DO!!!! "RTN","PXBPPRV",70,0) ;--IF Multiple deleting of entries "RTN","PXBPPRV",71,0) D DELM^PXBPPRV1 "RTN","PXBPPRV",72,0) I $G(NF) G P1 "RTN","PXBPPRV",73,0) ; "RTN","PXBPPRV",74,0) LI ;--If picked a line number "RTN","PXBPPRV",75,0) I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) S XFLAG=1 D REVPRV^PXBCC(DATA) S SELINE=DATA D "RTN","PXBPPRV",76,0) .I $G(FROM)["PL" Q "RTN","PXBPPRV",77,0) .I $G(FROM)["CPT" K SELINE S DATA="NOT VALID" Q "RTN","PXBPPRV",78,0) .F I=1:1:$L(DATA) W IOCUB,IOECH "RTN","PXBPPRV",79,0) .S PRISEC=$P($G(PXBSAM(DATA)),U,2) S:PRISEC["PRI" FPRI=0 "RTN","PXBPPRV",80,0) .S DATA=$P($G(PXBSAM(DATA)),U,1) "RTN","PXBPPRV",81,0) I $D(XFLAG),XFLAG=1 S Y=DATA G PFIN "RTN","PXBPPRV",82,0) ; "RTN","PXBPPRV",83,0) ;--If PRV is already in the file "RTN","PXBPPRV",84,0) I DATA="" S PXBUT=1 G PRVX "RTN","PXBPPRV",85,0) I $G(FROM)'="CPT",'$G(DOUBLEQQ),$D(PXBKY(DATA)) D "RTN","PXBPPRV",86,0) .I PXBCNT>10 D DPRV4^PXBDPRV($O(PXBKY(DATA,0))) "RTN","PXBPPRV",87,0) .K Q D TIMES^PXBUTL(DATA) "RTN","PXBPPRV",88,0) .I Q=1 S LINE=$O(PXBKY(DATA,0)) S XFLAG=1 D:$G(FROM)'="PL" REVPRV^PXBCC(LINE) S PRISEC=$P($G(PXBSAM(LINE)),"^",2) I $P(PXBSAM(LINE),"^",2)["PRI" S FPRI=0 "RTN","PXBPPRV",89,0) .I Q>1 S NLINE=0 F S NLINE=$O(Q(NLINE)) Q:NLINE="" D REVPRV^PXBCC(NLINE) "RTN","PXBPPRV",90,0) I $D(Q),Q>1 D WHICH^PXBPWCH G LI "RTN","PXBPPRV",91,0) I $D(XFLAG),XFLAG=1 S Y=DATA S:"CPT:PRV"[FROM&($G(D0)>0) Y="`"_D0 G PFIN "RTN","PXBPPRV",92,0) ;--Need to do a DIC lookup on data "RTN","PXBPPRV",93,0) ; "RTN","PXBPPRV",94,0) K FIRST "RTN","PXBPPRV",95,0) I DATA'="??" D:DATA="?" EN1^PXBHLP0("PXB","PRV",1,"",1) G:DATA="^P" P I DATA="?" G P "RTN","PXBPPRV",96,0) I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","PRV","",1,2) S:DATA="P" UDATA="^P" S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P(DATA,U,2) S:$G(UDATA)="" UDATA="^P" S:UDATA="^P" (DATA,EDATA,Y)=UDATA G:UDATA="^P" P1 G PFIN "RTN","PXBPPRV",97,0) ; "RTN","PXBPPRV",98,0) ;--If a "?" is NOT entered during lookup "RTN","PXBPPRV",99,0) ;----PX*1.0*152 "RTN","PXBPPRV",100,0) ;----If PXDEF152 is 1 then the user has hit the enter key with a specific provider provided as the default. "RTN","PXBPPRV",101,0) ;----There should be no need to prompt again. "RTN","PXBPPRV",102,0) I PXDEF152 D "RTN","PXBPPRV",103,0) .S X=DATA,DIC="^VA(200,",DIC(0)="O" "RTN","PXBPPRV",104,0) .D ^DIC S VAL=Y "RTN","PXBPPRV",105,0) .I Y<1 S PXDEF152=0 "RTN","PXBPPRV",106,0) ; begin patch *186* "RTN","PXBPPRV",107,0) ; I 'PXDEF152 S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM) "RTN","PXBPPRV",108,0) I 'PXDEF152 N PXOFROM S PXOFROM=FROM D S FROM=PXOFROM ;save FROM "RTN","PXBPPRV",109,0) . S FROM="PRV",(VAL,Y)=$$DOUBLE1^PXBGPRV2(FROM) "RTN","PXBPPRV",110,0) . I Y<1,$G(ERROR)=1,$G(CYCL)=1 D "RTN","PXBPPRV",111,0) . . D HELP1^PXBUTL1("CON") R X:DTIME "RTN","PXBPPRV",112,0) . . I PXOFROM'="CPT" D LOC^PXBCC(3,1) W IOEDEOP D EN0^PXBDPRV K CYCL "RTN","PXBPPRV",113,0) . . I PXOFROM="CPT" D LOC^PXBCC(4,1) W IOEDEOP N Y D HEADER^PXBMCPT2 "RTN","PXBPPRV",114,0) ; end patch *186* "RTN","PXBPPRV",115,0) I Y<1 S DATA="^P",DOUBLEQQ=1 G P1 "RTN","PXBPPRV",116,0) ;S (X,DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC "RTN","PXBPPRV",117,0) ; begin patch *186* "RTN","PXBPPRV",118,0) ; S X="`"_+Y,(DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC "RTN","PXBPPRV",119,0) ; I Y=-1 S PXBUT=1 G PRVX "RTN","PXBPPRV",120,0) S DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))" "RTN","PXBPPRV",121,0) S X="`"_+Y,(DATA,EDATA)=$P(VAL,U,2),DIC="^VA(200,",DIC(0)="MZ" D ^DIC "RTN","PXBPPRV",122,0) I Y=-1 D G PRVX "RTN","PXBPPRV",123,0) . D LOC^PXBCC(16,0),HELP^PXBUTL0("PRVM") "RTN","PXBPPRV",124,0) . D HELP1^PXBUTL1("CON") R X:DTIME "RTN","PXBPPRV",125,0) . D LOC^PXBCC(3,1) W IOEDEOP "RTN","PXBPPRV",126,0) . D LOC^PXBCC(15,0) "RTN","PXBPPRV",127,0) . S DATA="^P",PXBUT=1,FIRST=1 "RTN","PXBPPRV",128,0) . D:FROM="CPT" HEADER^PXBMCPT2 "RTN","PXBPPRV",129,0) ; end patch *186* "RTN","PXBPPRV",130,0) ;--If Y is good and already in file... "RTN","PXBPPRV",131,0) ;I '$G(DOUBLEQQ),$D(Y),$D(PXBKY($P(Y,"^",2))) D "RTN","PXBPPRV",132,0) I '$G(DOUBLEQQ),($P($G(Y),U)>0),$D(PRVN1($P(Y,U))) D "RTN","PXBPPRV",133,0) .S LINE=$P(PRVN1($P(Y,U)),U,5) "RTN","PXBPPRV",134,0) .S PRISEC=$P($G(PXBSAM(LINE)),"^",2) S:PRISEC["PRI" FPRI=0 "RTN","PXBPPRV",135,0) S PRV=Y(0) "RTN","PXBPPRV",136,0) ; "RTN","PXBPPRV",137,0) PFIN ;--Finish the Provider "RTN","PXBPPRV",138,0) I $L(Y,"^")'>1,$G(SELINE) S X="`"_$P(^AUPNVPRV($O(PXBSKY(SELINE,0)),0),"^",1),DIC="^VA(200,",DIC(0)="MZ" D ^DIC "RTN","PXBPPRV",139,0) I $L(Y,"^")'>1,'$G(SELINE) S X=Y,DIC="^VA(200,",DIC(0)="MZ" D ^DIC "RTN","PXBPPRV",140,0) I +Y<0 D HELP^PXBUTL0("PRVM") W IOCUU G P "RTN","PXBPPRV",141,0) S PRV=Y(0) "RTN","PXBPPRV",142,0) S PXBNPRV($P(PRV,U,1))="" "RTN","PXBPPRV",143,0) S PXBNPRVL(1)=$P(PRV,U,1) S ^DISV(DUZ,"PXBPRV-4")=$P(PRV,U,1) "RTN","PXBPPRV",144,0) I $D(PRVN1($P(Y,U))),$G(SELINE) S $P(REQI,U,7)=$O(PXBSKY(SELINE,0)),$P(REQI,U,2)=$P($G(PXBSAM(SELINE)),U,2) "RTN","PXBPPRV",145,0) I $D(PRVN1($P(Y,U))),'$G(SELINE) S PRVN1=PRVN1($P(Y,U)) D "RTN","PXBPPRV",146,0) .S $P(REQI,U,7)=$O(PXBSKY($P(PRVN1,U,5),0)) "RTN","PXBPPRV",147,0) .S PAT=$P(Y(0),U,1),ITEM=$P(PRVN1,U,5),$P(REQI,U,2)=$E($P(PRVN1,U,2),1),$P(REQE,U,2)=$P(PRVN1,U,2) "RTN","PXBPPRV",148,0) S $P(REQI,U,1)=+Y "RTN","PXBPPRV",149,0) I $P(REQI,U,2)']"" S $P(REQI,U,2)="S",$P(REQE,U,2)="SECONDARY" "RTN","PXBPPRV",150,0) S $P(REQE,U,1)=$P(PRV,U,1) "RTN","PXBPPRV",151,0) I '$D(REQI) S REQI="" "RTN","PXBPPRV",152,0) ;---IF INACTIVE ISSUE A WARNING "RTN","PXBPPRV",153,0) I DATA]"" D ACTIVE^PXBPPRV1 K DIR "RTN","PXBPPRV",154,0) PRVX ;--EXIT AND CLEAN UP "RTN","PXBPPRV",155,0) K PRVN1,VIEN,D0 "RTN","PXBPPRV",156,0) I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^" "RTN","PXBPPRV",157,0) I '$D(REQI) S REQI="" "RTN","PXBPPRV",158,0) I '$D(REQE) S REQE="" "RTN","PXBPPRV",159,0) I $P(REQE,U,1)="" S $P(REQE,U,1)="...No Provider Selected..." "RTN","PXBPPRV",160,0) ; begin patch *186* "RTN","PXBPPRV",161,0) ; I FROM="PRV",$L(EDATA)<40 D "RTN","PXBPPRV",162,0) I "CPT:PL:PRV"[FROM,$L(EDATA)<40 D "RTN","PXBPPRV",163,0) .F I=1:1:$L(ECHO) W IOCUB,IOELEOL "RTN","PXBPPRV",164,0) .F I=1:1:$L(ECHO) W IOCUF "RTN","PXBPPRV",165,0) .I $P(REQE,U,1)'["...No" W $P(REQE,U,1) "RTN","PXBPPRV",166,0) Q "RTN","PXBPPRV1") 0^4^B16413731 "RTN","PXBPPRV1",1,0) PXBPPRV1 ;ISL/JVS - PROMPT FOR PROVIDER ; 5/31/07 5:10pm "RTN","PXBPPRV1",2,0) ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,19,27,88,124,186**;Aug 12, 1996;Build 3 "RTN","PXBPPRV1",3,0) ; "RTN","PXBPPRV1",4,0) ; "RTN","PXBPPRV1",5,0) ; "RTN","PXBPPRV1",6,0) ACTIVE ;---CHECK TO SEE IF ACTIVE PROVIDER "RTN","PXBPPRV1",7,0) ; "RTN","PXBPPRV1",8,0) N PROVIDER,VISIT,DIC,DR,DA,INACTIVE,OK,NOT,PROVEX,BDATA,ACTIVE "RTN","PXBPPRV1",9,0) S PROVIDER=$P(REQI,"^",1) ;-Provider IEN "RTN","PXBPPRV1",10,0) S PROVEX=$P(REQE,"^",1) ;-Provider External form "RTN","PXBPPRV1",11,0) S VISIT=$P(IDATE,".",1) ;-Visit date Internal form "RTN","PXBPPRV1",12,0) ; "RTN","PXBPPRV1",13,0) ; begin patch *186* "RTN","PXBPPRV1",14,0) ;S DIC=200,DR=53.4,DA=PROVIDER,DIQ="INACTIVE",DIQ(0)="IN" D EN^DIQ1 "RTN","PXBPPRV1",15,0) ;I $D(INACTIVE),$G(INACTIVE(200,PROVIDER,53.4,"I"))VISIT S NOT=1 D "RTN","PXBPPRV1",23,0) . D RSET^PXBDREQ("PRV") S FPRI=1 "RTN","PXBPPRV1",24,0) . W !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," was TERMINATED before the date of this encounter.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME "RTN","PXBPPRV1",25,0) ; end patch *186* "RTN","PXBPPRV1",26,0) ; "RTN","PXBPPRV1",27,0) ;---------3/17/97--PART OF FUTURE PATCH 27 "RTN","PXBPPRV1",28,0) I '$G(NOT) D "RTN","PXBPPRV1",29,0) .N CLASS "RTN","PXBPPRV1",30,0) .S CLASS=+$$GET^XUA4A72(PROVIDER,$P(VISIT,".")) I CLASS<0 D "RTN","PXBPPRV1",31,0) ..D RSET^PXBDREQ("PRV") S FPRI=1 "RTN","PXBPPRV1",32,0) ..W !,IOEDEOP,IORVON,"--ERROR!--",PROVEX," does not have an ACTIVE person class.",IORVOFF D HELP1^PXBUTL1("CON") R OK:DTIME "RTN","PXBPPRV1",33,0) ;---------END 3/17/97 "RTN","PXBPPRV1",34,0) AXIT ;--EXIT AND KILL "RTN","PXBPPRV1",35,0) K DIQ "RTN","PXBPPRV1",36,0) Q "RTN","PXBPPRV1",37,0) PMPT ;--PROMT FOR COMFIRMATION OF USING INACTIVE PORVIDER "RTN","PXBPPRV1",38,0) S DIR("A")="Are you sure you want to select this provider? " "RTN","PXBPPRV1",39,0) S DIR("B")="NO" "RTN","PXBPPRV1",40,0) S DIR(0)="YA" "RTN","PXBPPRV1",41,0) D ^DIR "RTN","PXBPPRV1",42,0) I Y<1 D RSET^PXBDREQ("PRV") "RTN","PXBPPRV1",43,0) Q "RTN","PXBPPRV1",44,0) ; "RTN","PXBPPRV1",45,0) ADDM ;--------If Multiple entries have been entered "RTN","PXBPPRV1",46,0) Q "RTN","PXBPPRV1",47,0) ;---NOT POSSIBLE TO ADD MULTIPLE PROVIDERS "RTN","PXBPPRV1",48,0) ; "RTN","PXBPPRV1",49,0) DELM ;--------If Multiple deleting "RTN","PXBPPRV1",50,0) ; "RTN","PXBPPRV1",51,0) N DELM,CNT,CPTPRV,PXBJ,BAD,PXBLEN,BDATA "RTN","PXBPPRV1",52,0) S (NF,CNT)=0,PXBLEN=0 S $P(DELM,"^",1)=1 "RTN","PXBPPRV1",53,0) I $E(DATA,1)="@" S DATA=$P(DATA,"@",2),NF=1 D "RTN","PXBPPRV1",54,0) .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D "RTN","PXBPPRV1",55,0) ..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q "RTN","PXBPPRV1",56,0) ..I PXBPIECE'["-" D "RTN","PXBPPRV1",57,0) ...I $D(GONE(PXBPIECE)) Q "RTN","PXBPPRV1",58,0) ...Q:PXBPIECE'?.N "RTN","PXBPPRV1",59,0) ...Q:+PXBPIECE'=PXBPIECE "RTN","PXBPPRV1",60,0) ...S $P(REQI,"^",7)=$O(PXBSKY(PXBPIECE,0)) ;-IEN "RTN","PXBPPRV1",61,0) ...S X=$P(PXBSAM(PXBPIECE),"^",1),DIC="^VA(200,",DIC(0)="ZM" D ^DIC "RTN","PXBPPRV1",62,0) ...S $P(REQI,"^",1)=+Y S CPTPRV=+Y K Y "RTN","PXBPPRV1",63,0) ...S $P(REQI,"^",2)=$P(PXBSAM(PXBPIECE),"^",2) K Y "RTN","PXBPPRV1",64,0) ...S GONE(PXBPIECE)="" "RTN","PXBPPRV1",65,0) ...D EN0^PXBSTOR(PXBVST,PATIENT,REQI,$G(PXMREQ)) "RTN","PXBPPRV1",66,0) ...D EN1^PXKMAIN "RTN","PXBPPRV1",67,0) ...I $G(WHAT)["CPT" D DCPT^PXBSTOR1(CPTPRV,PXBVST) "RTN","PXBPPRV1",68,0) ..I PXBPIECE["-" D "RTN","PXBPPRV1",69,0) ...S PXBJ=0 F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D "RTN","PXBPPRV1",70,0) ....I $D(GONE(PXBJ)) Q "RTN","PXBPPRV1",71,0) ....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q "RTN","PXBPPRV1",72,0) ....S $P(REQI,"^",7)=$O(PXBSKY(PXBJ,0)) ;-IEN "RTN","PXBPPRV1",73,0) ....S X=$P(PXBSAM(PXBJ),"^",1),DIC="^VA(200,",DIC(0)="ZM" D ^DIC "RTN","PXBPPRV1",74,0) ....S $P(REQI,"^",1)=+Y S CPTPRV=+Y K Y "RTN","PXBPPRV1",75,0) ....S $P(REQI,"^",2)=$P(PXBSAM(PXBJ),"^",1) "RTN","PXBPPRV1",76,0) ....S GONE(PXBJ)="" "RTN","PXBPPRV1",77,0) ....D EN0^PXBSTOR(PXBVST,PATIENT,REQI,$G(PXMREQ)) "RTN","PXBPPRV1",78,0) ....D EN1^PXKMAIN "RTN","PXBPPRV1",79,0) ....I $G(WHAT)["CPT" D DCPT^PXBSTOR1(CPTPRV,PXBVST) "RTN","PXBPPRV1",80,0) K GONE "RTN","PXBPPRV1",81,0) I $G(NF)&($D(BAD)) D Q "RTN","PXBPPRV1",82,0) .S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" " "RTN","PXBPPRV1",83,0) .D WIN17^PXBCC(PXBCNT) "RTN","PXBPPRV1",84,0) .W ! D HELP^PXBUTL0("PRVMD") W ! "RTN","PXBPPRV1",85,0) .S DIR(0)="E" D ^DIR K DIR "RTN","PXBPPRV1",86,0) .S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y "RTN","PXBPPRV1",87,0) I $G(NF)&('$D(BAD)) S DATA="^P" Q "RTN","PXBPPRV1",88,0) K PRVDR,PXBDPRV "RTN","PXBPPRV1",89,0) Q "RTN","PXBPPRV1",90,0) ; "RTN","PXBPPRV1",91,0) PRI ;--Prompt for primary secondary provider "RTN","PXBPPRV1",92,0) ; "RTN","PXBPPRV1",93,0) N DIR,Y,X "RTN","PXBPPRV1",94,0) I $G(FPRI) Q "RTN","PXBPPRV1",95,0) W IOCUD,IOELALL,IOCUU "RTN","PXBPPRV1",96,0) S DIR("A")="Is this the PRIMARY provider for this ENCOUNTER? " "RTN","PXBPPRV1",97,0) S DIR("B")="YES" "RTN","PXBPPRV1",98,0) S DIR("?")="One PRIMARY Provider must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY." "RTN","PXBPPRV1",99,0) S DIR(0)="Y,A,O" "RTN","PXBPPRV1",100,0) D ^DIR I $G(DIRUT) G PPXIT "RTN","PXBPPRV1",101,0) PPFIN ;--Finish off variables "RTN","PXBPPRV1",102,0) I Y=1 S PRI="P^PRIMARY" "RTN","PXBPPRV1",103,0) I Y=0 S PRI="S^SECONDARY" "RTN","PXBPPRV1",104,0) S $P(REQI,"^",2)=$P(PRI,"^",1) "RTN","PXBPPRV1",105,0) S $P(REQE,"^",2)=$P(PRI,"^",2) "RTN","PXBPPRV1",106,0) PPXIT ;--EXIT "RTN","PXBPPRV1",107,0) Q "RTN","PXKMAIN2") 0^9^B10938982 "RTN","PXKMAIN2",1,0) PXKMAIN2 ;ISL/JVS - Special Routine ;5/21/96 13:20 "RTN","PXKMAIN2",2,0) ;;1.0;PCE PATIENT CARE ENCOUNTER;**69,186**;Aug 12, 1996;Build 3 "RTN","PXKMAIN2",3,0) ; VARIABLES "RTN","PXKMAIN2",4,0) ; See variables lists under each line tag "RTN","PXKMAIN2",5,0) ; "RTN","PXKMAIN2",6,0) ; "RTN","PXKMAIN2",7,0) SPEC ;Populate other v files "RTN","PXKMAIN2",8,0) ; VARIABLES "RTN","PXKMAIN2",9,0) ; PXKAV(0) = The AFTER variables created in PXKMAIN "RTN","PXKMAIN2",10,0) ; PXKBV(0) = The BEFORE variables created in PXKMAIN "RTN","PXKMAIN2",11,0) ; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags "RTN","PXKMAIN2",12,0) ; PXKCAT = The category being $o through (CPT,IMM etc...) "RTN","PXKMAIN2",13,0) ; PXKIN = The pointer value of first piece in the mapping file "RTN","PXKMAIN2",14,0) ; PXKPXD = An array with all the entries to be mapped this go around "RTN","PXKMAIN2",15,0) ; PXKDIEN = IEN of the coding file "RTN","PXKMAIN2",16,0) ; "RTN","PXKMAIN2",17,0) S PXKDONE=0 "RTN","PXKMAIN2",18,0) Q:PXKFGED=1 "RTN","PXKMAIN2",19,0) I (PXKFGAD=1) D "RTN","PXKMAIN2",20,0) .I $D(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1)) D "RTN","PXKMAIN2",21,0) ..S PXKDONE=$O(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE)) "RTN","PXKMAIN2",22,0) ..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN "RTN","PXKMAIN2",23,0) ..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN "RTN","PXKMAIN2",24,0) ..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE "RTN","PXKMAIN2",25,0) ..S PXJ(4)=$P(PXJ(1),"^",4) ;TO "RTN","PXKMAIN2",26,0) ..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0)) "RTN","PXKMAIN2",27,0) ..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP "RTN","PXKMAIN2",28,0) I (PXKFGDE=1) D "RTN","PXKMAIN2",29,0) .I $D(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1)) D "RTN","PXKMAIN2",30,0) ..S PXKDONE=$O(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE)) "RTN","PXKMAIN2",31,0) ..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN "RTN","PXKMAIN2",32,0) ..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN "RTN","PXKMAIN2",33,0) ..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE "RTN","PXKMAIN2",34,0) ..S PXJ(4)=$P(PXJ(1),"^",4) ;TO "RTN","PXKMAIN2",35,0) ..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0)) "RTN","PXKMAIN2",36,0) ..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP "RTN","PXKMAIN2",37,0) K PXKDONE "RTN","PXKMAIN2",38,0) Q "RTN","PXKMAIN2",39,0) ; "RTN","PXKMAIN2",40,0) POP ;Population of more than one v file using PCE CODE MAPPING file 811.1 "RTN","PXKMAIN2",41,0) ; "RTN","PXKMAIN2",42,0) ;N PXKPXD "RTN","PXKMAIN2",43,0) N PXKROU,PXKIN,PXKX,PXKXX,PXKDIEN,PXKTO "RTN","PXKMAIN2",44,0) S PXKIN=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"") "RTN","PXKMAIN2",45,0) S PXKDIEN=0 F S PXKDIEN=$O(^PXD(811.1,"AA",PXKIN,PXKCAT,1,PXKDIEN)) Q:PXKDIEN="" D "RTN","PXKMAIN2",46,0) .S PXKPXD(PXKDIEN)=$G(^PXD(811.1,PXKDIEN,0)) "RTN","PXKMAIN2",47,0) S (PXKX,PXKXX)=0 F S PXKX=$O(PXKPXD(PXKX)) Q:PXKX="" S PXKXX=PXKXX+.01 D "RTN","PXKMAIN2",48,0) .I TMPPX[("^"_PXKX_"^") Q "RTN","PXKMAIN2",49,0) .S PXKTO=$P(PXKPXD(PXKX),"^",4) "RTN","PXKMAIN2",50,0) .S PXKROU=$P(PXKPXD(PXKX),"^",3)_"^PXKF"_PXKTO_"1" D @PXKROU "RTN","PXKMAIN2",51,0) .S TMPPX=TMPPX_PXKX_"^" "RTN","PXKMAIN2",52,0) S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR")) "RTN","PXKMAIN2",53,0) S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN")) "RTN","PXKMAIN2",54,0) Q "RTN","PXKMAIN2",55,0) ; "RTN","PXKMAIN2",56,0) RECALL ; Recall PXKMAIN to populate special circumstances "RTN","PXKMAIN2",57,0) D EVENT^PXKMAIN K ^TMP("PXK",$J) "RTN","PXKMAIN2",58,0) S PXKREF="^TMP(""PXKSAVE"",$J)" "RTN","PXKMAIN2",59,0) F S PXKREF=$Q(@PXKREF) Q:$P(PXKREF,",",1)'["PXKSAVE" Q:$P(PXKREF,",",2)'[$J Q:PXKREF="" S PXKSAVE=PXKREF D "RTN","PXKMAIN2",60,0) .S $P(PXKSAVE,"""",2)="PXK" S @PXKSAVE=$G(@PXKREF) "RTN","PXKMAIN2",61,0) S ^TMP("PXK",$J,"SOR")=$G(PXKNORG("SOR")) "RTN","PXKMAIN2",62,0) S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXKNORG("VSTIEN")) "RTN","PXKMAIN2",63,0) K ^TMP("PXKSAVE",$J),PXKNORG "RTN","PXKMAIN2",64,0) D EN1^PXKMAIN,EVENT^PXKMAIN "RTN","PXKMAIN2",65,0) Q "RTN","PXKMAIN2",66,0) ; "RTN","PXKMAIN2",67,0) ; "RTN","PXKMAIN2",68,0) PRVTYPE ;---POPULATE PROVIDER TYPE "RTN","PXKMAIN2",69,0) ; "RTN","PXKMAIN2",70,0) ;--** "RTN","PXKMAIN2",71,0) I '$D(^TMP("PXK",$J,"PRV")) Q "RTN","PXKMAIN2",72,0) I '$L($T(GET^XUA4A72)) Q "RTN","PXKMAIN2",73,0) N PXKPSUB,PXKPRV,PXKDT,NOD0,TYPE "RTN","PXKMAIN2",74,0) S PXKPSUB=0 F S PXKPSUB=$O(^TMP("PXK",$J,"PRV",PXKPSUB)) Q:PXKPSUB="" D "RTN","PXKMAIN2",75,0) .S NOD0=$G(^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER")) "RTN","PXKMAIN2",76,0) .S PXKPRV=$P(NOD0,"^",1) "RTN","PXKMAIN2",77,0) .I '$G(PXKPRV) Q "RTN","PXKMAIN2",78,0) .S PXKDT=+$P($G(^AUPNVSIT($G(^TMP("PXK",$J,"VST",1,"IEN")),0)),"^",1) "RTN","PXKMAIN2",79,0) .;--** ADD FUNCTION "RTN","PXKMAIN2",80,0) .S TYPE=+$$GET^XUA4A72($G(PXKPRV),+$P($G(PXKDT),".")) Q:TYPE<1 "RTN","PXKMAIN2",81,0) .I $P(NOD0,"^",6)']"" S $P(NOD0,"^",6)=TYPE "RTN","PXKMAIN2",82,0) .S ^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER")=NOD0 "RTN","PXKMAIN2",83,0) Q "VER") 8.0^22.0 **INSTALL NAME** SD*5.3*516 "BLD",6659,0) SD*5.3*516^SCHEDULING^0^3070918^y "BLD",6659,1,0) ^^2^2^3070628^ "BLD",6659,1,1,0) Please refer to patch SD*5.3*516 in the National Patch Module for a "BLD",6659,1,2,0) complete description of this patch. "BLD",6659,4,0) ^9.64PA^^ "BLD",6659,6.3) 3 "BLD",6659,"KRN",0) ^9.67PA^8989.52^19 "BLD",6659,"KRN",.4,0) .4 "BLD",6659,"KRN",.401,0) .401 "BLD",6659,"KRN",.402,0) .402 "BLD",6659,"KRN",.403,0) .403 "BLD",6659,"KRN",.5,0) .5 "BLD",6659,"KRN",.84,0) .84 "BLD",6659,"KRN",3.6,0) 3.6 "BLD",6659,"KRN",3.8,0) 3.8 "BLD",6659,"KRN",9.2,0) 9.2 "BLD",6659,"KRN",9.8,0) 9.8 "BLD",6659,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",6659,"KRN",9.8,"NM",1,0) SDUTL2^^0^B50944268 "BLD",6659,"KRN",9.8,"NM","B","SDUTL2",1) "BLD",6659,"KRN",19,0) 19 "BLD",6659,"KRN",19.1,0) 19.1 "BLD",6659,"KRN",101,0) 101 "BLD",6659,"KRN",409.61,0) 409.61 "BLD",6659,"KRN",771,0) 771 "BLD",6659,"KRN",870,0) 870 "BLD",6659,"KRN",8989.51,0) 8989.51 "BLD",6659,"KRN",8989.52,0) 8989.52 "BLD",6659,"KRN",8994,0) 8994 "BLD",6659,"KRN","B",.4,.4) "BLD",6659,"KRN","B",.401,.401) "BLD",6659,"KRN","B",.402,.402) "BLD",6659,"KRN","B",.403,.403) "BLD",6659,"KRN","B",.5,.5) "BLD",6659,"KRN","B",.84,.84) "BLD",6659,"KRN","B",3.6,3.6) "BLD",6659,"KRN","B",3.8,3.8) "BLD",6659,"KRN","B",9.2,9.2) "BLD",6659,"KRN","B",9.8,9.8) "BLD",6659,"KRN","B",19,19) "BLD",6659,"KRN","B",19.1,19.1) "BLD",6659,"KRN","B",101,101) "BLD",6659,"KRN","B",409.61,409.61) "BLD",6659,"KRN","B",771,771) "BLD",6659,"KRN","B",870,870) "BLD",6659,"KRN","B",8989.51,8989.51) "BLD",6659,"KRN","B",8989.52,8989.52) "BLD",6659,"KRN","B",8994,8994) "BLD",6659,"QUES",0) ^9.62^^ "BLD",6659,"REQB",0) ^9.611^1^1 "BLD",6659,"REQB",1,0) SD*5.3*380^2 "BLD",6659,"REQB","B","SD*5.3*380",1) "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 "PKG",16,22,1,"PAH",1,0) 516^3070918^123456810 "PKG",16,22,1,"PAH",1,1,0) ^^2^2^3070918 "PKG",16,22,1,"PAH",1,1,1,0) Please refer to patch SD*5.3*516 in the National Patch Module for a "PKG",16,22,1,"PAH",1,1,2,0) complete description of this patch. "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") NO "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") NO "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") NO "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") 1 "RTN","SDUTL2") 0^1^B50944268 "RTN","SDUTL2",1,0) SDUTL2 ;ALB/CAW - Misc. utilities ; 6/28/07 11:48am "RTN","SDUTL2",2,0) ;;5.3;Scheduling;**20,71,132,149,175,193,220,258,380,516**;Aug 13, 1993;Build 3 "RTN","SDUTL2",3,0) ; "RTN","SDUTL2",4,0) ; "RTN","SDUTL2",5,0) FYNUNK(SD) ; return YES, NO, UNKNOWN "RTN","SDUTL2",6,0) ; input: SD=internal piece "RTN","SDUTL2",7,0) ; output: [returned] Y=YES, N=NO, U=UNKNOWN "RTN","SDUTL2",8,0) Q $S(SD="Y":"YES",SD="N":"NO",SD="U":"UNKNOWN",1:"") "RTN","SDUTL2",9,0) ; "RTN","SDUTL2",10,0) FMT(DFN) ; return current status of means test in external form "RTN","SDUTL2",11,0) ; input: DFN=ifn of patient "RTN","SDUTL2",12,0) ; ouput: [returned] MT^SMT^LST "RTN","SDUTL2",13,0) ; MT=external format of current status "RTN","SDUTL2",14,0) ; SMT=shortened format of current staus "RTN","SDUTL2",15,0) ; LST=date of last test "RTN","SDUTL2",16,0) ; "RTN","SDUTL2",17,0) N X,Y "RTN","SDUTL2",18,0) S X=$$LST^DGMTU(DFN) "RTN","SDUTL2",19,0) S Y=$P(X,U,4),Y=$S(Y["B":"CAT "_Y,Y["A":"COPAY EX",Y["C":"COPAY REQ",Y["G":"GMT COPAY REQ",Y["R":"REQ",Y["P":"PEND ADJ",Y["N":"NOT REQ",1:"") "RTN","SDUTL2",20,0) Q $P(X,U,3)_U_Y_U_$P(X,U,2) "RTN","SDUTL2",21,0) ; "RTN","SDUTL2",22,0) FCO(DFN) ; return current status of copay test in external form "RTN","SDUTL2",23,0) ; input: DFN=ifn of patient "RTN","SDUTL2",24,0) ; ouput: [returned] COT^SCOT^LST "RTN","SDUTL2",25,0) ; COT=external format of current status "RTN","SDUTL2",26,0) ; SCOT=shortened format of current staus "RTN","SDUTL2",27,0) ; LST=date of last test "RTN","SDUTL2",28,0) ; "RTN","SDUTL2",29,0) N X,Y "RTN","SDUTL2",30,0) S X=$$LST^DGMTU(DFN,"",2) "RTN","SDUTL2",31,0) S Y=$P(X,U,4),Y=$S(Y["E":"EXEMPT",Y["M":"NON-EXEMPT",Y["I":"INCOMPLETE",Y["L":"NO LONGER APPL.",1:"") "RTN","SDUTL2",32,0) Q $P(X,U,3)_U_Y_U_$P(X,U,2) "RTN","SDUTL2",33,0) ; "RTN","SDUTL2",34,0) XMY(GROUP,SDUZ,SDPOST) ; -- set up XMY for mail group members "RTN","SDUTL2",35,0) ; input: GROUP := mail group efn [required] "RTN","SDUTL2",36,0) ; SDUZ := send to current user [ 0|no ; 1|yes] [optional] "RTN","SDUTL2",37,0) ; SDPOST := send to postmaster if XMY is undefined "RTN","SDUTL2",38,0) ; [ 0|no ; 1|yes] [optional] "RTN","SDUTL2",39,0) ; output: XMY := array of users "RTN","SDUTL2",40,0) ; XMDUZ := message sender set postmaster "RTN","SDUTL2",41,0) ; "RTN","SDUTL2",42,0) N I K XMY "RTN","SDUTL2",43,0) I '$D(SDUZ) N SDUZ S SDUZ=1 "RTN","SDUTL2",44,0) I '$D(SDPOST) N SDPOST S SDPOST=1 "RTN","SDUTL2",45,0) S XMY("G."_$P($G(^XMB(3.8,GROUP,0)),U))="" "RTN","SDUTL2",46,0) I SDUZ,DUZ S XMY(DUZ)="" "RTN","SDUTL2",47,0) ; makes sure it gets sent to someone "RTN","SDUTL2",48,0) I '$D(XMY),SDPOST S XMY(.5)="" "RTN","SDUTL2",49,0) ; make postmaster the sender so it will show up as new to DUZ "RTN","SDUTL2",50,0) S XMDUZ=.5 "RTN","SDUTL2",51,0) Q "RTN","SDUTL2",52,0) ; "RTN","SDUTL2",53,0) SCREEN(Y,SDDT) ; -- screen called when entering a provider in the "RTN","SDUTL2",54,0) ; DEFAULT PROVIDER field (#16) or PROVIDER field (#.01) of the PROVIDER "RTN","SDUTL2",55,0) ; multiple (#2600) in the HOSPITAL LOCATION file (#44). "RTN","SDUTL2",56,0) ; "RTN","SDUTL2",57,0) ; Selects active providers with an active entry in the NEW PERSON "RTN","SDUTL2",58,0) ; file (#200) for PERSON CLASS. "RTN","SDUTL2",59,0) ; "RTN","SDUTL2",60,0) ; INPUT: Y = ien of file 200 "RTN","SDUTL2",61,0) ; SDDT = today's date "RTN","SDUTL2",62,0) ; OUTPUT: 1 to select; 0 to not select "RTN","SDUTL2",63,0) ; "RTN","SDUTL2",64,0) ; begin patch *516* "RTN","SDUTL2",65,0) ; DBIA #2349 - ACTIVE PROVIDER will be used for validation. "RTN","SDUTL2",66,0) ; The INACTIVE DATE (#53.4) field will no longer be used. "RTN","SDUTL2",67,0) ; New input selection logic... "RTN","SDUTL2",68,0) ; The TERMINATION DATE (#9.2) and the PERSON CLASS (#8932.1) fields "RTN","SDUTL2",69,0) ; will be used to determine if selection is active in the "RTN","SDUTL2",70,0) ; NEW PERSON (#200) file for a given date. "RTN","SDUTL2",71,0) ; "RTN","SDUTL2",72,0) ;S:'+$G(SDDT) SDDT=DT I '+$G(Y) Q 0 "RTN","SDUTL2",73,0) ;N SDINACT,SDT,SDY S SDY=0 "RTN","SDUTL2",74,0) ; check if provider active "RTN","SDUTL2",75,0) ;S SDINACT=$G(^VA(200,+Y,"PS")) "RTN","SDUTL2",76,0) ;Q:'$S(SDINACT']"":1,'+$P(SDINACT,"^",4):1,DT<+$P(SDINACT,"^",4):1,1:0) SDY "RTN","SDUTL2",77,0) ;S SDT=+$P($G(^VA(200,+Y,0)),U,11) "RTN","SDUTL2",78,0) ;Q:$S('SDT:0,(SDT0 S SDY=1 "RTN","SDUTL2",80,0) ; "RTN","SDUTL2",81,0) I '+$G(Y) Q 0 "RTN","SDUTL2",82,0) N SDY "RTN","SDUTL2",83,0) S:'+$G(SDDT) SDDT=DT "RTN","SDUTL2",84,0) S SDY=0,SDDT=$P(SDDT,".") "RTN","SDUTL2",85,0) I $$ACTIVPRV^PXAPI(+Y,SDDT) S SDY=1 ;DBIA #2349 "RTN","SDUTL2",86,0) ; end patch *516* "RTN","SDUTL2",87,0) Q SDY "RTN","SDUTL2",88,0) ; "RTN","SDUTL2",89,0) HELP(SDDT) ; -- executable help called when entering a provider in the "RTN","SDUTL2",90,0) ; DEFAULT PROVIDER field (#16) or PROVIDER field (#.01) of the PROVIDER "RTN","SDUTL2",91,0) ; multiple (#2600) in the HOSPITAL LOCATION file (#44), the PROVIDER "RTN","SDUTL2",92,0) ; (#.01) field of the V PROVIDER file (#9000010.06), or in the "RTN","SDUTL2",93,0) ; PROVIDER prompt of the Check-out screen. display active providers "RTN","SDUTL2",94,0) ; with an active entry in the NEW PERSON file (#200) for PERSON CLASS. "RTN","SDUTL2",95,0) ; "RTN","SDUTL2",96,0) ; INPUT: SDDT = today's date "RTN","SDUTL2",97,0) ; OUTPUT: display of active providers with an active entry in the NEW "RTN","SDUTL2",98,0) ; PERSON file (#200) for PERSON CLASS "RTN","SDUTL2",99,0) ; "RTN","SDUTL2",100,0) S:'+$G(SDDT) SDDT=DT "RTN","SDUTL2",101,0) N D,DO,DIC,X "RTN","SDUTL2",102,0) S X="??",DIC="^VA(200,",DIC(0)="EQ",D="B" "RTN","SDUTL2",103,0) S DIC("S")="I $$SCREEN^SDUTL2(Y,SDDT)" "RTN","SDUTL2",104,0) D IX^DIC "RTN","SDUTL2",105,0) Q "RTN","SDUTL2",106,0) ; "RTN","SDUTL2",107,0) SCAN(SDINDEX,SDBEG,SDEND,SDCB,SDFN,SDIR) ; -- api to invoke scan "RTN","SDUTL2",108,0) N SDQID "RTN","SDUTL2",109,0) D OPEN^SDQ(.SDQID) "RTN","SDUTL2",110,0) D INDEX^SDQ(.SDQID,SDINDEX,"SET") "RTN","SDUTL2",111,0) IF SDINDEX="PATIENT/DATE"!(SDINDEX="PATIENT") D PAT^SDQ(.SDQID,SDFN,"SET") "RTN","SDUTL2",112,0) IF SDINDEX="PATIENT/DATE"!(SDINDEX="DATE/TIME") D DATE^SDQ(.SDQID,SDBEG,SDEND,"SET") "RTN","SDUTL2",113,0) D SCANCB^SDQ(.SDQID,SDCB,"SET") "RTN","SDUTL2",114,0) D ACTIVE^SDQ(.SDQID,"TRUE","SET") "RTN","SDUTL2",115,0) D SCAN^SDQ(.SDQID,SDIR) "RTN","SDUTL2",116,0) D CLOSE^SDQ(.SDQID) "RTN","SDUTL2",117,0) SCANQ Q "RTN","SDUTL2",118,0) ; "RTN","SDUTL2",119,0) MHCLIN(SDCL,SDSC) ;;Determines if Mental health Clinic requiring GAF "RTN","SDUTL2",120,0) ;;This will be a supported call "RTN","SDUTL2",121,0) ;;Determines whether the clinic passed is a Mental Health clinic that requires Gaf "RTN","SDUTL2",122,0) ;;Input - SDCL = Clinic IEN "RTN","SDUTL2",123,0) ;; SDSC = DSS Stop Code [Optional] "RTN","SDUTL2",124,0) ;; For Visit File entries where the Clinic IEN is not available "RTN","SDUTL2",125,0) ;; but the DSS identifier is. "RTN","SDUTL2",126,0) ;; "RTN","SDUTL2",127,0) ;;Output - 1 = Mental health clinic requiring a Gaf "RTN","SDUTL2",128,0) ;; 0 = Not a clinic requiring a Gaf "RTN","SDUTL2",129,0) N SDNOGAF,SDSTOP,SDCS,SDMH "RTN","SDUTL2",130,0) S SDNOGAF="526,527,528,530,533,536,537,542,545,546,565,566,573,574,579" "RTN","SDUTL2",131,0) ;; Get either the Clinic IEN or the Clinic Stop code "RTN","SDUTL2",132,0) I $G(SDCL) D "RTN","SDUTL2",133,0) . S SDSTOP=$P($G(^SC(SDCL,0)),"^",7) "RTN","SDUTL2",134,0) E D "RTN","SDUTL2",135,0) . S SDSTOP=$G(SDSC) "RTN","SDUTL2",136,0) ; "RTN","SDUTL2",137,0) S SDCS=$P($G(^DIC(40.7,+SDSTOP,0)),"^",2),SDMH=$S(SDNOGAF[SDCS:0,$E(SDCS)=5:1,1:0) "RTN","SDUTL2",138,0) Q SDMH "RTN","SDUTL2",139,0) ; "RTN","SDUTL2",140,0) NEWGAF(DFN) ;;Determine if new GAF Score needed "RTN","SDUTL2",141,0) ;;This will be a supported call "RTN","SDUTL2",142,0) ;;Determines if a new Gaf is required for a patient and retrieves previous Gaf data "RTN","SDUTL2",143,0) ;; If patient is deceased, returns a 0, no new GAF required "RTN","SDUTL2",144,0) ;; "RTN","SDUTL2",145,0) ;;Input - Patient IEN "RTN","SDUTL2",146,0) ;;Output: "RTN","SDUTL2",147,0) ;; piece 1 = -1 if New Gaf needed and no previous data "RTN","SDUTL2",148,0) ;; = 1 if New Gaf needed and previous data exists "RTN","SDUTL2",149,0) ;; = 0 if no New Gaf needed and previous exists "RTN","SDUTL2",150,0) ;; piece 2 = previous Gaf score "RTN","SDUTL2",151,0) ;; piece 3 = previous Gaf date "RTN","SDUTL2",152,0) ;; piece 4 = previous Gaf Providers IEN "RTN","SDUTL2",153,0) ;; "RTN","SDUTL2",154,0) N SDGAF,SDGAFDT,VADM "RTN","SDUTL2",155,0) ; "RTN","SDUTL2",156,0) S SDGAF=$$RET^YSGAF(DFN) "RTN","SDUTL2",157,0) ;; Check for deceased patient. "RTN","SDUTL2",158,0) D DEM^VADPT "RTN","SDUTL2",159,0) Q:+$G(VADM(6)) "0^"_SDGAF_"^1" "RTN","SDUTL2",160,0) D KVAR^VADPT "RTN","SDUTL2",161,0) ; "RTN","SDUTL2",162,0) Q:SDGAF=-1 -1 "RTN","SDUTL2",163,0) S X1=$P(SDGAF,"^",2),X2=90 D C^%DTC "RTN","SDUTL2",164,0) Q $S(DT>X:1,1:0)_"^"_SDGAF "RTN","SDUTL2",165,0) ; "RTN","SDUTL2",166,0) GAFCM() ;; "RTN","SDUTL2",167,0) N DIR,DIRUT "RTN","SDUTL2",168,0) S DIR("A",1)="But a new GAF Score is needed for this patient!" "RTN","SDUTL2",169,0) S DIR("A")="Are you sure you want to bypass the check out screen? " "RTN","SDUTL2",170,0) S DIR("B")="No",DIR(0)="YA" W ! D ^DIR "RTN","SDUTL2",171,0) Q +$G(Y) "RTN","SDUTL2",172,0) COLLAT(SDEC) ;Determines if patient has a collateral eligibility status "RTN","SDUTL2",173,0) ; "RTN","SDUTL2",174,0) ; INPUT: SDEC = patient eligibility status "RTN","SDUTL2",175,0) ; "RTN","SDUTL2",176,0) ; OUTPUT: 1 = collateral patient "RTN","SDUTL2",177,0) ; 0 = non-collateral patient "RTN","SDUTL2",178,0) ; "RTN","SDUTL2",179,0) Q:$G(SDEC)="" 0 "RTN","SDUTL2",180,0) I $$GET1^DIQ(8,SDEC,8,"I")=13 Q 1 "RTN","SDUTL2",181,0) Q 0 "RTN","SDUTL2",182,0) ; "RTN","SDUTL2",183,0) ELSTAT(DA) ;Retrieve patient eligibility status "RTN","SDUTL2",184,0) ; "RTN","SDUTL2",185,0) ; INPUT: DA = patient IEN "RTN","SDUTL2",186,0) ; "RTN","SDUTL2",187,0) ; OUTPUT: "RTN","SDUTL2",188,0) ; Function Value - returns the internal entry number for patient's "RTN","SDUTL2",189,0) ; eligibility status. "RTN","SDUTL2",190,0) ; "RTN","SDUTL2",191,0) Q:$G(DA)="" "" "RTN","SDUTL2",192,0) Q $$GET1^DIQ(2,DA,.361,"I") "RTN","SDUTL2",193,0) SCREST(SCIEN,TYP,DIS) ;check stop code restriction in file 40.7 for a clinic. "RTN","SDUTL2",194,0) ; INPUT: SCIEN = IEN of Stop Code "RTN","SDUTL2",195,0) ; TYP = Stop Code Type, Primary (P) or Secondary (S) "RTN","SDUTL2",196,0) ; DIS = Message Display, 1 - Display or 0 No Display "RTN","SDUTL2",197,0) ; "RTN","SDUTL2",198,0) ; OUTPUT: 1 if no error, or 0^error message "RTN","SDUTL2",199,0) ; "RTN","SDUTL2",200,0) N SCN,RTY,CTY,RDT,STR,STYP "RTN","SDUTL2",201,0) S DIS=$G(DIS,0),STYP="("_$S(TYP="P":"Prim",1:"Second")_"ary)" "RTN","SDUTL2",202,0) I +SCIEN<1 S STR="Invalid Clinic Stop Code "_STYP_"." D MSG Q "0^"_STR "RTN","SDUTL2",203,0) S CTY=$S(TYP="P":"^P^E^",1:"^S^E^") "RTN","SDUTL2",204,0) S SCN=$G(^DIC(40.7,SCIEN,0)),RTY=$P(SCN,U,6),RDT=$P(SCN,U,7) "RTN","SDUTL2",205,0) I RTY="" D Q "0^"_STR "RTN","SDUTL2",206,0) .S STR="Clinic's Stop Code "_$P(SCN,U,2)_" has no restriction type "_STYP_"." D MSG "RTN","SDUTL2",207,0) I CTY'[("^"_RTY_"^") D D MSG Q "0^"_STR "RTN","SDUTL2",208,0) .S STR="Clinic's Stop Code "_$P(SCN,U,2)_" cannot be "_$S(TYP="P":"Prim",1:"Second")_"ary." "RTN","SDUTL2",209,0) I RDT>DT D D MSG Q "0^"_STR "RTN","SDUTL2",210,0) .S STR="Clinic's Stop Code "_$P(SCN,U,2)_" cannot be used. Restriction date is "_$$FMTE^XLFDT(RDT,"1F")_" "_STYP_"." "RTN","SDUTL2",211,0) Q 1 "RTN","SDUTL2",212,0) MSG ;display error message to screen "RTN","SDUTL2",213,0) I DIS,$E($G(IOST))="C" W !?5,STR "RTN","SDUTL2",214,0) Q "RTN","SDUTL2",215,0) CLNCK(CLN,DSP) ;Check clinic for valid stop code restriction. "RTN","SDUTL2",216,0) ; INPUT: CLN = IEN of Clinic "RTN","SDUTL2",217,0) ; DSP = Error Message Display, 1 - Display or 0 No Display "RTN","SDUTL2",218,0) ; "RTN","SDUTL2",219,0) ; OUTPUT: 1 if no error or 0^error message "RTN","SDUTL2",220,0) N PSC,SSC,ND0,VAL "RTN","SDUTL2",221,0) S DSP=$G(DSP,0) "RTN","SDUTL2",222,0) I CLN="" D Q "0^"_"Invalid Clinic." "RTN","SDUTL2",223,0) .I DSP,$E($G(IOST))="C" W !?5,"Invalid Clinic." "RTN","SDUTL2",224,0) I $G(^SC(CLN,0))="" D Q "0^"_"Clinic not define or has no zero node." "RTN","SDUTL2",225,0) .I DSP,$E($G(IOST))="C" W !?5,"Clinic not define or has no zero node." "RTN","SDUTL2",226,0) S ND0=^SC(CLN,0),PSC=$P(ND0,U,7),SSC=$P(ND0,U,18),DSP=$G(DSP,0) "RTN","SDUTL2",227,0) I $P(ND0,U,3)'="C" Q 1 ;not a Clinic "RTN","SDUTL2",228,0) S VAL=$$SCREST(PSC,"P",DSP) "RTN","SDUTL2",229,0) Q:'VAL VAL Q:SSC="" 1 "RTN","SDUTL2",230,0) S VAL=$$SCREST(SSC,"S",DSP) "RTN","SDUTL2",231,0) Q VAL "VER") 8.0^22.0 **END** **END**