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
