- SDPBE ;BP-IOFO/OWAIN ; Pharmacy Benefits National Reporting. ; 7/23/03
- ;;5.3;Scheduling;**300,1015**;AUG 13, 1993;Build 21
- N SDSS,DFN
- D INIT(.SDSS)
- S DFN=0
- F S DFN=$O(^SDWL(409.3,"B",DFN)) Q:+DFN'=DFN D
- .N SDENCFLG,SDSEQ,SDINST,ELIGIBLE,SDDAPT
- .I $D(^PS(52.91,DFN,0)) Q
- .Q:'$$PAT(DFN)
- .S SDENCFLG=0 D ENC I SDENCFLG Q
- .K SDENCFLG
- .S SDSEQ=0
- .F S SDSEQ=$O(^SDWL(409.3,"B",DFN,SDSEQ)) Q:+SDSEQ'=SDSEQ D
- ..N SDPSOLES,SDPSOWT,SDWL0,SDODT,SDWLCL,SDCL,SDCP,SDDISDT,SDAPPDT,SDREQBY,SDMEDD
- ..S SDWL0=$G(^SDWL(409.3,SDSEQ,0))
- ..S SDPSOWT=$P(SDWL0,"^",5)
- ..;Quit-no Wait Type, check current 4 only, in case other codes are added
- ..I SDPSOWT'=1,SDPSOWT'=2,SDPSOWT'=3,SDPSOWT'=4 Q
- ..D GETCL
- ..;SDCL Returned for types 1,2,4 Clinic^Institution^Station
- ..;SDCL Returned for type 3 "VALID"^Institution^station
- ..I $G(SDCL)="" Q
- ..S SDODT=$P(SDWL0,"^",2) I 'SDODT Q
- ..Q:$E(SDODT,1,7)>3030724
- ..;I SDPSOWT=1!(SDPSOWT=2) I '$P(SDWL0,"^",2) Q
- ..I SDPSOWT=3!(SDPSOWT=4) I '$P(SDWL0,"^",2),'$P(SDWL0,"^",16) Q
- ..I SDPSOWT=1!(SDPSOWT=2) I $$FMDIFF^XLFDT(DT,$P(SDWL0,"^",2),1)'>29 Q
- ..I SDPSOWT=3!(SDPSOWT=4) S SDPSOLES=0 D I 'SDPSOLES Q
- ...I $P(SDWL0,"^",2),$$FMDIFF^XLFDT(DT,$P(SDWL0,"^",2),1)>29 S SDPSOLES=1 Q
- ...I $P(SDWL0,"^",16),$$FMDIFF^XLFDT(DT,$P(SDWL0,"^",16),1)>29 S SDPSOLES=1
- ..S SDDISDT=$P($G(^SDWL(409.3,SDSEQ,"DIS")),U)
- ..S SDINST=$P(SDCL,"^",2) Q:'SDINST
- ..I $D(ELIGIBLE(SDINST)) Q:$P(ELIGIBLE(SDINST),U,2)<SDODT
- ..; If disposition date is not before 9/22/2003 (or there is no disposition date) - ELIGIBLE, otherwise INELIGIBLE.
- ..I SDDISDT<3030922&(SDDISDT'="") Q
- ..S ELIGIBLE(SDINST)=1_U_SDODT_U_$P(SDWL0,U,16) ; 1^Originating date^Desired date.
- ..Q
- .S SDINST=""
- .F S SDINST=$O(ELIGIBLE(SDINST)) Q:SDINST="" I ELIGIBLE(SDINST) D
- ..I $P(ELIGIBLE(SDINST),"^",3) S ^XTMP("SDPSO145","PAT","E",DFN,SDINST,$P(ELIGIBLE(SDINST),"^",3))="" Q
- ..; If desired date null, use DT, set to 1 to indicate no desire date
- ..S ^XTMP("SDPSO145","PAT","E",DFN,SDINST,DT)=1
- .Q
- Q
- ;
- INIT(SDSS) ;
- N SDI,SDII
- ;
- ; Primary care stop code 404: GYNECOLOGY was added after the specification. (The 404 code has been removed)
- F SDI=322,323,350 F SDII="000",185,186,187 S SDSS(SDI_SDII)=""
- Q
- ;
- PAT(DFN) ;Evaluate a patient
- ;INPUT: DFN=patient ien
- ;OUTPUT: (fail) 0^_<reason for failure>
- ; (success) 1^Patient appears to be eligible
- ;
- ;N ENR
- Q:'$D(^DPT(DFN,0)) "0^Patient record not found"
- Q:+$G(^DPT(DFN,.35)) "0^Patient is deceased"
- Q:$P($G(^DPT(DFN,"VET")),U)'="Y" "0^Patient is not a veteran"
- Q:+$P($G(^DPT(DFN,.15)),U,2) "0^Patient is ineligible"
- Q:'$L($P($G(^DPT(DFN,0)),U)) "0^Invalid name value"
- Q:$D(^DPT(DFN,-9)) "0^Merged patient record"
- Q:$P(^DPT(DFN,0),U)["MERGING INTO" "0^Merging patient record"
- Q:$$TESTPAT^VADPT(DFN) "0^Test patient"
- ;S ENR=$$GET1^DIQ(2,DFN_",",27.01,"I") Q:ENR=""!($$GET1^DIQ(27.11,ENR_",",.01,"I")>3030829) "0^Not enrolled by date required"
- Q "1^Patient appears to be eligible"
- ;
- CPAIR(SDCL0) ; Get credit pair
- ; Input: SDCL0=hospital location zeroeth node
- N SDX
- S SDX=$P($G(^DIC(40.7,+$P(SDCL0,U,7),0)),U,2)
- S SDX=SDX_$P($G(^DIC(40.7,+$P(SDCL0,U,18),0)),U,2)
- S SDX=$E(SDX_"000000",1,6)
- Q SDX
- ;
- GETCL ;Get clinic info
- ;Need to set SDCL = Clinic IEN
- N SDPSONOX,SDCL0,SDWTXXX,SDPSOWLQ,SDPSOWSP,SDPSOWLA,SDPSOWL
- S SDCL=""
- I $G(SDPSOWT)=1 S SDPSONOX=0 D S:$G(SDPSONOX)&($G(SDCL)="") ^XTMP("SDPSO145","PROB1",DFN)="" Q
- .S SDPSOWSP=$P(SDWL0,"^",6) I 'SDPSOWSP!('$D(^SCTM(404.51,+$G(SDPSOWSP),0))) Q
- .S SDPSOWL="" F S SDPSOWL=$O(^SCTM(404.57,"C",SDPSOWSP,SDPSOWL)) Q:SDPSOWL="" I $P($G(^SCTM(404.57,SDPSOWL,0)),"^",9) S SDPSOWLA(+$P($G(^SCTM(404.57,SDPSOWL,0)),"^",9))=""
- .S SDPSOWLQ=0,SDPSOWL="" F S SDPSOWL=$O(SDPSOWLA(SDPSOWL)) Q:SDPSOWL=""!(SDPSOWLQ) D
- ..;Fine first clinic with valid Institution and Station Number
- ..D INSTA
- I $G(SDPSOWT)=2 D Q
- .N SDPSOPOS
- .S SDPSOPOS=$P(SDWL0,"^",7) I 'SDPSOPOS Q
- .S SDPSOWL=$P($G(^SCTM(404.57,SDPSOPOS,0)),"^",9) I 'SDPSOWL Q
- .D INSTA
- I $G(SDPSOWT)=3 D Q
- .N SDPSOWSC,SDPSOAMI,SDPSOAMX
- .S SDWTX=$P(SDWL0,"^",3) I 'SDWTX!('$D(^DIC(4,+$G(SDWTX),0))) Q
- .;D STNM I $G(SDWTXXX)="" Q
- .S SDPSOWSC=$P(SDWL0,"^",8) I 'SDPSOWSC Q
- .S SDPSOAMI=$P($G(^SDWL(409.31,SDPSOWSC,0)),"^") I 'SDPSOAMI Q
- .S SDPSOAMX=$P($G(^DIC(40.7,SDPSOAMI,0)),"^",2)
- .S SDPSOAMX=$E(SDPSOAMX_"000000",1,6)
- .I $D(SDSS(SDPSOAMX)) S SDCL="VALID"_"^"_SDWTX
- I $G(SDPSOWT)=4 D Q
- .N SDPSO9
- .S SDPSO9=$P(SDWL0,"^",9) I 'SDPSO9 Q
- .S SDPSOWL=$P($G(^SDWL(409.32,SDPSO9,0)),"^") I 'SDPSOWL Q
- .D INSTA
- Q
- INSTA ;
- I $G(SDPSOWL)'>0 Q
- N SDWTX,SDMEDDX
- S SDWTX=$P($G(^SC(SDPSOWL,0)),"^",4) I SDWTX>0,$D(^DIC(4,SDWTX,0)) G STNMP
- S SDWTX="" S SDMEDDX=$P($G(^SC(SDPSOWL,0)),"^",15) I SDMEDDX>0 S SDWTX=$P($$SITE^VASITE(,SDMEDDX),"^")
- I $G(SDWTX)'>0 Q
- I '$D(^DIC(4,SDWTX,0)) Q
- STNMP ;
- ;I $G(SDWTXXX)'="" D
- I $G(SDPSOWT)=1 S SDCL0=$G(^SC(SDPSOWL,0)) S SDCP=$$CPAIR(SDCL0) D STNM D K SDWTXXX Q
- .I $D(SDSS(SDCP)) D
- ..I $G(SDWTXXX)="" S SDPSONOX=1 Q
- ..S SDCL=SDPSOWL_"^"_SDWTX,SDPSOWLQ=1
- S SDCL0=$G(^SC(SDPSOWL,0)) S SDCP=$$CPAIR(SDCL0) I $D(SDSS(SDCP)) S SDCL=SDPSOWL_"^"_SDWTX
- Q
- ;I $G(SDCL) Q
- ;S SDMEDDX=$P($G(^SC(SDPSOWL,0)),"^",15) I SDMEDDX>0 S SDWTX=$P($$SITE^VASITE(,SDMEDDX),"^") I $G(SDWTX),$D(^DIC(4,+$G(SDWTX),0)) D STNM D Q
- ;.I $G(SDWTXXX)'="" D
- ;..I $G(SDPSOWT)=1 S SDCL0=$G(^SC(SDPSOWL,0)) S SDCP=$$CPAIR(SDCL0) D Q
- ;...I $D(SDSS(SDCP)) S SDCL=SDPSOWL_"^"_SDWTX_"^"_SDWTXXX,SDPSOWLQ=1
- ;..S SDCL0=$G(^SC(SDPSOWL,0)) S SDCP=$$CPAIR(SDCL0) I $D(SDSS(SDCP)) S SDCL=SDPSOWL_"^"_SDWTX_"^"_SDWTXXX
- Q
- STNM N SDWTXX
- K SDWTXX,SDWTXXX,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+SDWTX,DIQ(0)="I",DIQ="SDWTXX" D EN^DIQ1 S SDWTXXX=$G(SDWTXX(4,+SDWTX,99,"I")) K DIC,DIQ,DR,DA,SDWTXX
- Q
- ENC ;Encounter check
- N SDENC,SDENC1,SDENC2,SDENC3,SDENC4
- S SDENC=3011021.2359
- F S SDENC=$O(^SCE("ADFN",DFN,SDENC)) Q:'SDENC!(SDENCFLG) D
- .S SDENC1=0 F S SDENC1=$O(^SCE("ADFN",DFN,SDENC,SDENC1)) Q:'SDENC1!(SDENCFLG) D
- ..S SDENC2=$G(^SCE(SDENC1,0)) Q:'$L(SDENC2)
- ..Q:$P(SDENC2,"^",6)
- ..Q:'$P(SDENC2,"^",4)
- ..S SDENC3=$G(^SC(+$P(SDENC2,"^",4),0)) Q:'$L(SDENC3)
- ..S SDENC4=$$CPAIR(SDENC3)
- ..Q:'$D(SDSS(SDENC4))
- ..K ^XTMP("SDPSO145","PAT","E",DFN)
- ..K ^XTMP("SDPSO145","PAT","S",DFN) S SDENCFLG=1
- Q
- SDPBE ;BP-IOFO/OWAIN ; Pharmacy Benefits National Reporting. ; 7/23/03
- +1 ;;5.3;Scheduling;**300,1015**;AUG 13, 1993;Build 21
- +2 NEW SDSS,DFN
- +3 DO INIT(.SDSS)
- +4 SET DFN=0
- +5 FOR
- SET DFN=$ORDER(^SDWL(409.3,"B",DFN))
- IF +DFN'=DFN
- QUIT
- Begin DoDot:1
- +6 NEW SDENCFLG,SDSEQ,SDINST,ELIGIBLE,SDDAPT
- +7 IF $DATA(^PS(52.91,DFN,0))
- QUIT
- +8 IF '$$PAT(DFN)
- QUIT
- +9 SET SDENCFLG=0
- DO ENC
- IF SDENCFLG
- QUIT
- +10 KILL SDENCFLG
- +11 SET SDSEQ=0
- +12 FOR
- SET SDSEQ=$ORDER(^SDWL(409.3,"B",DFN,SDSEQ))
- IF +SDSEQ'=SDSEQ
- QUIT
- Begin DoDot:2
- +13 NEW SDPSOLES,SDPSOWT,SDWL0,SDODT,SDWLCL,SDCL,SDCP,SDDISDT,SDAPPDT,SDREQBY,SDMEDD
- +14 SET SDWL0=$GET(^SDWL(409.3,SDSEQ,0))
- +15 SET SDPSOWT=$PIECE(SDWL0,"^",5)
- +16 ;Quit-no Wait Type, check current 4 only, in case other codes are added
- +17 IF SDPSOWT'=1
- IF SDPSOWT'=2
- IF SDPSOWT'=3
- IF SDPSOWT'=4
- QUIT
- +18 DO GETCL
- +19 ;SDCL Returned for types 1,2,4 Clinic^Institution^Station
- +20 ;SDCL Returned for type 3 "VALID"^Institution^station
- +21 IF $GET(SDCL)=""
- QUIT
- +22 SET SDODT=$PIECE(SDWL0,"^",2)
- IF 'SDODT
- QUIT
- +23 IF $EXTRACT(SDODT,1,7)>3030724
- QUIT
- +24 ;I SDPSOWT=1!(SDPSOWT=2) I '$P(SDWL0,"^",2) Q
- +25 IF SDPSOWT=3!(SDPSOWT=4)
- IF '$PIECE(SDWL0,"^",2)
- IF '$PIECE(SDWL0,"^",16)
- QUIT
- +26 IF SDPSOWT=1!(SDPSOWT=2)
- IF $$FMDIFF^XLFDT(DT,$PIECE(SDWL0,"^",2),1)'>29
- QUIT
- +27 IF SDPSOWT=3!(SDPSOWT=4)
- SET SDPSOLES=0
- Begin DoDot:3
- +28 IF $PIECE(SDWL0,"^",2)
- IF $$FMDIFF^XLFDT(DT,$PIECE(SDWL0,"^",2),1)>29
- SET SDPSOLES=1
- QUIT
- +29 IF $PIECE(SDWL0,"^",16)
- IF $$FMDIFF^XLFDT(DT,$PIECE(SDWL0,"^",16),1)>29
- SET SDPSOLES=1
- End DoDot:3
- IF 'SDPSOLES
- QUIT
- +30 SET SDDISDT=$PIECE($GET(^SDWL(409.3,SDSEQ,"DIS")),U)
- +31 SET SDINST=$PIECE(SDCL,"^",2)
- IF 'SDINST
- QUIT
- +32 IF $DATA(ELIGIBLE(SDINST))
- IF $PIECE(ELIGIBLE(SDINST),U,2)<SDODT
- QUIT
- +33 ; If disposition date is not before 9/22/2003 (or there is no disposition date) - ELIGIBLE, otherwise INELIGIBLE.
- +34 IF SDDISDT<3030922&(SDDISDT'="")
- QUIT
- +35 ; 1^Originating date^Desired date.
- SET ELIGIBLE(SDINST)=1_U_SDODT_U_$PIECE(SDWL0,U,16)
- +36 QUIT
- End DoDot:2
- +37 SET SDINST=""
- +38 FOR
- SET SDINST=$ORDER(ELIGIBLE(SDINST))
- IF SDINST=""
- QUIT
- IF ELIGIBLE(SDINST)
- Begin DoDot:2
- +39 IF $PIECE(ELIGIBLE(SDINST),"^",3)
- SET ^XTMP("SDPSO145","PAT","E",DFN,SDINST,$PIECE(ELIGIBLE(SDINST),"^",3))=""
- QUIT
- +40 ; If desired date null, use DT, set to 1 to indicate no desire date
- +41 SET ^XTMP("SDPSO145","PAT","E",DFN,SDINST,DT)=1
- End DoDot:2
- +42 QUIT
- End DoDot:1
- +43 QUIT
- +44 ;
- INIT(SDSS) ;
- +1 NEW SDI,SDII
- +2 ;
- +3 ; Primary care stop code 404: GYNECOLOGY was added after the specification. (The 404 code has been removed)
- +4 FOR SDI=322,323,350
- FOR SDII="000",185,186,187
- SET SDSS(SDI_SDII)=""
- +5 QUIT
- +6 ;
- PAT(DFN) ;Evaluate a patient
- +1 ;INPUT: DFN=patient ien
- +2 ;OUTPUT: (fail) 0^_<reason for failure>
- +3 ; (success) 1^Patient appears to be eligible
- +4 ;
- +5 ;N ENR
- +6 IF '$DATA(^DPT(DFN,0))
- QUIT "0^Patient record not found"
- +7 IF +$GET(^DPT(DFN,.35))
- QUIT "0^Patient is deceased"
- +8 IF $PIECE($GET(^DPT(DFN,"VET")),U)'="Y"
- QUIT "0^Patient is not a veteran"
- +9 IF +$PIECE($GET(^DPT(DFN,.15)),U,2)
- QUIT "0^Patient is ineligible"
- +10 IF '$LENGTH($PIECE($GET(^DPT(DFN,0)),U))
- QUIT "0^Invalid name value"
- +11 IF $DATA(^DPT(DFN,-9))
- QUIT "0^Merged patient record"
- +12 IF $PIECE(^DPT(DFN,0),U)["MERGING INTO"
- QUIT "0^Merging patient record"
- +13 IF $$TESTPAT^VADPT(DFN)
- QUIT "0^Test patient"
- +14 ;S ENR=$$GET1^DIQ(2,DFN_",",27.01,"I") Q:ENR=""!($$GET1^DIQ(27.11,ENR_",",.01,"I")>3030829) "0^Not enrolled by date required"
- +15 QUIT "1^Patient appears to be eligible"
- +16 ;
- CPAIR(SDCL0) ; Get credit pair
- +1 ; Input: SDCL0=hospital location zeroeth node
- +2 NEW SDX
- +3 SET SDX=$PIECE($GET(^DIC(40.7,+$PIECE(SDCL0,U,7),0)),U,2)
- +4 SET SDX=SDX_$PIECE($GET(^DIC(40.7,+$PIECE(SDCL0,U,18),0)),U,2)
- +5 SET SDX=$EXTRACT(SDX_"000000",1,6)
- +6 QUIT SDX
- +7 ;
- GETCL ;Get clinic info
- +1 ;Need to set SDCL = Clinic IEN
- +2 NEW SDPSONOX,SDCL0,SDWTXXX,SDPSOWLQ,SDPSOWSP,SDPSOWLA,SDPSOWL
- +3 SET SDCL=""
- +4 IF $GET(SDPSOWT)=1
- SET SDPSONOX=0
- Begin DoDot:1
- +5 SET SDPSOWSP=$PIECE(SDWL0,"^",6)
- IF 'SDPSOWSP!('$DATA(^SCTM(404.51,+$GET(SDPSOWSP),0)))
- QUIT
- +6 SET SDPSOWL=""
- FOR
- SET SDPSOWL=$ORDER(^SCTM(404.57,"C",SDPSOWSP,SDPSOWL))
- IF SDPSOWL=""
- QUIT
- IF $PIECE($GET(^SCTM(404.57,SDPSOWL,0)),"^",9)
- SET SDPSOWLA(+$PIECE($GET(^SCTM(404.57,SDPSOWL,0)),"^",9))=""
- +7 SET SDPSOWLQ=0
- SET SDPSOWL=""
- FOR
- SET SDPSOWL=$ORDER(SDPSOWLA(SDPSOWL))
- IF SDPSOWL=""!(SDPSOWLQ)
- QUIT
- Begin DoDot:2
- +8 ;Fine first clinic with valid Institution and Station Number
- +9 DO INSTA
- End DoDot:2
- End DoDot:1
- IF $GET(SDPSONOX)&($GET(SDCL)="")
- SET ^XTMP("SDPSO145","PROB1",DFN)=""
- QUIT
- +10 IF $GET(SDPSOWT)=2
- Begin DoDot:1
- +11 NEW SDPSOPOS
- +12 SET SDPSOPOS=$PIECE(SDWL0,"^",7)
- IF 'SDPSOPOS
- QUIT
- +13 SET SDPSOWL=$PIECE($GET(^SCTM(404.57,SDPSOPOS,0)),"^",9)
- IF 'SDPSOWL
- QUIT
- +14 DO INSTA
- End DoDot:1
- QUIT
- +15 IF $GET(SDPSOWT)=3
- Begin DoDot:1
- +16 NEW SDPSOWSC,SDPSOAMI,SDPSOAMX
- +17 SET SDWTX=$PIECE(SDWL0,"^",3)
- IF 'SDWTX!('$DATA(^DIC(4,+$GET(SDWTX),0)))
- QUIT
- +18 ;D STNM I $G(SDWTXXX)="" Q
- +19 SET SDPSOWSC=$PIECE(SDWL0,"^",8)
- IF 'SDPSOWSC
- QUIT
- +20 SET SDPSOAMI=$PIECE($GET(^SDWL(409.31,SDPSOWSC,0)),"^")
- IF 'SDPSOAMI
- QUIT
- +21 SET SDPSOAMX=$PIECE($GET(^DIC(40.7,SDPSOAMI,0)),"^",2)
- +22 SET SDPSOAMX=$EXTRACT(SDPSOAMX_"000000",1,6)
- +23 IF $DATA(SDSS(SDPSOAMX))
- SET SDCL="VALID"_"^"_SDWTX
- End DoDot:1
- QUIT
- +24 IF $GET(SDPSOWT)=4
- Begin DoDot:1
- +25 NEW SDPSO9
- +26 SET SDPSO9=$PIECE(SDWL0,"^",9)
- IF 'SDPSO9
- QUIT
- +27 SET SDPSOWL=$PIECE($GET(^SDWL(409.32,SDPSO9,0)),"^")
- IF 'SDPSOWL
- QUIT
- +28 DO INSTA
- End DoDot:1
- QUIT
- +29 QUIT
- INSTA ;
- +1 IF $GET(SDPSOWL)'>0
- QUIT
- +2 NEW SDWTX,SDMEDDX
- +3 SET SDWTX=$PIECE($GET(^SC(SDPSOWL,0)),"^",4)
- IF SDWTX>0
- IF $DATA(^DIC(4,SDWTX,0))
- GOTO STNMP
- +4 SET SDWTX=""
- SET SDMEDDX=$PIECE($GET(^SC(SDPSOWL,0)),"^",15)
- IF SDMEDDX>0
- SET SDWTX=$PIECE($$SITE^VASITE(,SDMEDDX),"^")
- +5 IF $GET(SDWTX)'>0
- QUIT
- +6 IF '$DATA(^DIC(4,SDWTX,0))
- QUIT
- STNMP ;
- +1 ;I $G(SDWTXXX)'="" D
- +2 IF $GET(SDPSOWT)=1
- SET SDCL0=$GET(^SC(SDPSOWL,0))
- SET SDCP=$$CPAIR(SDCL0)
- DO STNM
- Begin DoDot:1
- +3 IF $DATA(SDSS(SDCP))
- Begin DoDot:2
- +4 IF $GET(SDWTXXX)=""
- SET SDPSONOX=1
- QUIT
- +5 SET SDCL=SDPSOWL_"^"_SDWTX
- SET SDPSOWLQ=1
- End DoDot:2
- End DoDot:1
- KILL SDWTXXX
- QUIT
- +6 SET SDCL0=$GET(^SC(SDPSOWL,0))
- SET SDCP=$$CPAIR(SDCL0)
- IF $DATA(SDSS(SDCP))
- SET SDCL=SDPSOWL_"^"_SDWTX
- +7 QUIT
- +8 ;I $G(SDCL) Q
- +9 ;S SDMEDDX=$P($G(^SC(SDPSOWL,0)),"^",15) I SDMEDDX>0 S SDWTX=$P($$SITE^VASITE(,SDMEDDX),"^") I $G(SDWTX),$D(^DIC(4,+$G(SDWTX),0)) D STNM D Q
- +10 ;.I $G(SDWTXXX)'="" D
- +11 ;..I $G(SDPSOWT)=1 S SDCL0=$G(^SC(SDPSOWL,0)) S SDCP=$$CPAIR(SDCL0) D Q
- +12 ;...I $D(SDSS(SDCP)) S SDCL=SDPSOWL_"^"_SDWTX_"^"_SDWTXXX,SDPSOWLQ=1
- +13 ;..S SDCL0=$G(^SC(SDPSOWL,0)) S SDCP=$$CPAIR(SDCL0) I $D(SDSS(SDCP)) S SDCL=SDPSOWL_"^"_SDWTX_"^"_SDWTXXX
- +14 QUIT
- STNM NEW SDWTXX
- +1 KILL SDWTXX,SDWTXXX,DIC,DIQ,DD,DR
- SET DIC=4
- SET DR="99"
- SET DA=+SDWTX
- SET DIQ(0)="I"
- SET DIQ="SDWTXX"
- DO EN^DIQ1
- SET SDWTXXX=$GET(SDWTXX(4,+SDWTX,99,"I"))
- KILL DIC,DIQ,DR,DA,SDWTXX
- +2 QUIT
- ENC ;Encounter check
- +1 NEW SDENC,SDENC1,SDENC2,SDENC3,SDENC4
- +2 SET SDENC=3011021.2359
- +3 FOR
- SET SDENC=$ORDER(^SCE("ADFN",DFN,SDENC))
- IF 'SDENC!(SDENCFLG)
- QUIT
- Begin DoDot:1
- +4 SET SDENC1=0
- FOR
- SET SDENC1=$ORDER(^SCE("ADFN",DFN,SDENC,SDENC1))
- IF 'SDENC1!(SDENCFLG)
- QUIT
- Begin DoDot:2
- +5 SET SDENC2=$GET(^SCE(SDENC1,0))
- IF '$LENGTH(SDENC2)
- QUIT
- +6 IF $PIECE(SDENC2,"^",6)
- QUIT
- +7 IF '$PIECE(SDENC2,"^",4)
- QUIT
- +8 SET SDENC3=$GET(^SC(+$PIECE(SDENC2,"^",4),0))
- IF '$LENGTH(SDENC3)
- QUIT
- +9 SET SDENC4=$$CPAIR(SDENC3)
- +10 IF '$DATA(SDSS(SDENC4))
- QUIT
- +11 KILL ^XTMP("SDPSO145","PAT","E",DFN)
- +12 KILL ^XTMP("SDPSO145","PAT","S",DFN)
- SET SDENCFLG=1
- End DoDot:2
- End DoDot:1
- +13 QUIT
