SDPHARM1 ;BIRMINGHAM OIFO/RON - Determine default Institution/Station no. ; 8/9/03
;;5.3;Scheduling;**300,314,318**;AUG 13, 1993
;
DEF(SDPSODFN) ;Pass in Patient
I '$G(SDPSODFN)!('$D(^DPT(SDPSODFN,0))) Q 0
N DA,DR,DIC,DIE,DIQ,X,Y,SDPSODSS,SDPSOPRM,SDPSODFA,SDPSODF1,SDPSODF2,SDPSODF3,SDPSOPDF
D INIT
D PAT
I '$D(SDPSODFA) Q 0
S (SDPSOPRM,SDPSOPDF)=0
S SDPSODF1="" F S SDPSODF1=$O(SDPSODFA(SDPSODF1)) Q:SDPSODF1=""!(SDPSOPRM) S SDPSODF2="" F S SDPSODF2=$O(SDPSODFA(SDPSODF1,SDPSODF2)) Q:SDPSODF2=""!(SDPSOPRM) D
.S SDPSODF3="" F S SDPSODF3=$O(SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3)) Q:SDPSODF3=""!(SDPSOPRM) D
..I SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3) S SDPSOPDF=SDPSODF2_"^"_SDPSODF3,SDPSOPRM=1 Q
..S SDPSOPDF=SDPSODF2_"^"_SDPSODF3
Q $S(SDPSOPDF:SDPSOPDF,1:0)
INIT ;Initialize variables
;Create primary care DSS credit pair array
N SDPSODI,SDPSODII
F SDPSODI=322,323,350 F SDPSODII="000",185,186,187 S SDPSODSS(SDPSODI_SDPSODII)=""
Q
;
PAT ;
N SDPSOSTA,SDPSOATZ,SDPSODIV,SDPSODCP,SDPSOCL0,SDPSOAP0,SDPSOSDT,SDPSOOUT,X,Y,X1,X2
S SDPSOOUT=0
I '$G(DT) S DT=$$DT^XLFDT
;S X1=DT,X2=-1 D C^%DTC S SDPSOSDT=X_".2359"
;Call scheduling API for appointment information
N SDPSOCNT,SDPSOSDI
K ^TMP($J,"SDAMA201","GETAPPT")
D GETAPPT^SDAMA201(SDPSODFN,"1;2","R",DT,,.SDPSOCNT)
I $G(SDPSOCNT)>0 D
.F SDPSOSDI=1:1:SDPSOCNT S SDPSOAP0=+$G(^TMP($J,"SDAMA201","GETAPPT",SDPSOSDI,2)) D
..;Q:$P(SDPSOAP0,U,2)["C" ;Skip cancelled appointments
..S SDPSOCL0=$G(^SC(+SDPSOAP0,0)) Q:'$L(SDPSOCL0) ;Get clinic 0 node
..S SDPSODCP=$$CPAIR(SDPSOCL0) ;Get DSS credit pair
..S SDPSODIV=$$DIV(SDPSOCL0) ;Get clinic division
..K SDPSOSTA I $G(SDPSODIV) K SDPSOATZ,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+SDPSODIV,DIQ(0)="I",DIQ="SDPSOATZ" D EN^DIQ1 S SDPSOSTA=$G(SDPSOATZ(4,+SDPSODIV,99,"I")) K DIC,DIQ,DR,DA,SDPSOATZ
..I SDPSODIV>0,$G(SDPSOSTA)'="" D
...S SDPSOSDT=$P($G(^TMP($J,"SDAMA201","GETAPPT",SDPSOSDI,1)),"^") I SDPSOSDT D
....S SDPSODFA(SDPSOSDT,SDPSODIV,SDPSOSTA)=$S($D(SDPSODSS(SDPSODCP)):1,1:0)
K ^TMP($J,"SDAMA201","GETAPPT")
Q
;
CPAIR(SDPSOCL0) ;Get credit pair
N SDPSOSDX
S SDPSOSDX=$P($G(^DIC(40.7,+$P(SDPSOCL0,U,7),0)),U,2)
S SDPSOSDX=SDPSOSDX_$P($G(^DIC(40.7,+$P(SDPSOCL0,U,18),0)),U,2)
S SDPSOSDX=$E(SDPSOSDX_"000000",1,6)
Q SDPSOSDX
;
DIV(SDPSOCL0) ;Get facility division name and number
N SDPSODVX,SDPSOHLD S SDPSODVX=$P(SDPSOCL0,U,15)
S SDPSOHLD=0
I SDPSODVX>0 S SDPSOHLD=$P($$SITE^VASITE(,SDPSODVX),U)
I SDPSOHLD>0 Q SDPSOHLD
S SDPSOHLD=$P(SDPSOCL0,"^",4)
I 'SDPSOHLD Q 0
I SDPSOHLD K ^UTILITY("DIQ1",$J),DIQ S DA=SDPSOHLD,DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S:$G(^UTILITY("DIQ1",$J,4,DA,.01,"E"))="" SDPSOHLD=0 K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
Q SDPSOHLD
;
PRIAPT(SDPSOPAT) ;Find nearest Primary care appt, past or future
I '$G(DT) S DT=$$DT^XLFDT
I '$G(SDPSOPAT) Q ""
N SDPSODSS,X1,X2,X,Y
D INIT
N SDPSOQEC,SDPSOX,SDPSOX1,SDPSOX2,SDPSOX3,SDPSOX4,SDPSOX5,SDPSOX6,SDPSOX7,SDPSOX8,SDPSOX9,SDPSOX10,SDPSOX11,SDPSOX12,SDPSOX13,SDPSOX14,SDPSOX15
S SDPSOX=" "
S SDPSOQEC=0
F S SDPSOX=$O(^SCE("ADFN",SDPSOPAT,SDPSOX),-1),SDPSOX1=0 Q:'SDPSOX!(SDPSOQEC)!(SDPSOX<3030725) F S SDPSOX1=$O(^SCE("ADFN",SDPSOPAT,SDPSOX,SDPSOX1)) Q:'SDPSOX1!(SDPSOQEC) D
.S SDPSOX2=$G(^SCE(SDPSOX1,0)) Q:'$L(SDPSOX2)
.Q:$P(SDPSOX2,"^",6)
.Q:'$P(SDPSOX2,"^",4)
.;next line, checking for only "CHECKED OUT" and INPATIENT encounters
.I $P(SDPSOX2,"^",12)'=2,$P(SDPSOX2,"^",12)'=8 Q
.S SDPSOX3=$G(^SC(+$P(SDPSOX2,"^",4),0)) Q:'$L(SDPSOX3)
.S SDPSOX4=$$CPAIR(SDPSOX3)
.Q:'$D(SDPSODSS(SDPSOX4))
.S SDPSOX5(SDPSOPAT,"ENC")=SDPSOX_"^"_+$P(SDPSOX2,"^",4),SDPSOQEC=1
;S X1=DT,X2=-1 D C^%DTC S SDPSOX6=X_.2359
N SDPSOCOU,SDPSODSI
K ^TMP($J,"SDAMA201","GETAPPT")
D GETAPPT^SDAMA201(SDPSOPAT,"1;2","R",DT,,.SDPSOCOU)
I $G(SDPSOCOU)>0 D
.F SDPSODSI=1:1:SDPSOCOU S SDPSOX7=+$G(^TMP($J,"SDAMA201","GETAPPT",SDPSODSI,2)) Q:$D(SDPSOX10(SDPSOPAT,"APP")) D
..;Q:$P(SDPSOX7,"^",2)["C"
..S SDPSOX8=$G(^SC(+SDPSOX7,0)) Q:'$L(SDPSOX8)
..S SDPSOX9=$$CPAIR(SDPSOX8)
..Q:'$D(SDPSODSS(SDPSOX9))
..S SDPSOX6=$P($G(^TMP($J,"SDAMA201","GETAPPT",SDPSODSI,1)),"^")
..I '$D(SDPSOX10(SDPSOPAT,"APP")) S SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7 Q
..I SDPSOX6<$P($G(SDPSOX10(SDPSOPAT,"APP")),"^") S SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7
K ^TMP($J,"SDAMA201","GETAPPT")
I '$D(SDPSOX10(SDPSOPAT,"APP")),'$D(SDPSOX5(SDPSOPAT,"ENC")) Q ""
I $D(SDPSOX10(SDPSOPAT,"APP")),'$D(SDPSOX5(SDPSOPAT,"ENC")) D APPX Q SDPSOX11
I $D(SDPSOX5(SDPSOPAT,"ENC")),'$D(SDPSOX10(SDPSOPAT,"APP")) D APPE Q SDPSOX11
S SDPSOX12=$P(SDPSOX10(SDPSOPAT,"APP"),"^"),SDPSOX14=$$FMDIFF^XLFDT(SDPSOX12,DT,1)
S SDPSOX12=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") S:SDPSOX12<0 SDPSOX12=$E(SDPSOX12,2,$L(SDPSOX12)) S SDPSOX15=$$FMDIFF^XLFDT(DT,SDPSOX12,1)
;Encounter wins ties
I SDPSOX14=SDPSOX15 D APPE Q SDPSOX11
I SDPSOX15>SDPSOX14 D APPX Q SDPSOX11
D APPE Q SDPSOX11
APPX ;
S Y=$P(SDPSOX10(SDPSOPAT,"APP"),"^") D DD^%DT S SDPSOX11=Y_" "_$P($G(^SC(+$P($G(SDPSOX10(SDPSOPAT,"APP")),"^",2),0)),"^")
S SDPSOX12=$P(SDPSOX10(SDPSOPAT,"APP"),"^") S SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1) S SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
Q
APPE ;
S Y=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") D DD^%DT S SDPSOX11=Y_" "_$P($G(^SC(+$P($G(SDPSOX5(SDPSOPAT,"ENC")),"^",2),0)),"^")
S SDPSOX12=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") S SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1) S SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDPHARM1 5497 printed Apr 09, 2024@21:50:51 Page 2
SDPHARM1 ;BIRMINGHAM OIFO/RON - Determine default Institution/Station no. ; 8/9/03
+1 ;;5.3;Scheduling;**300,314,318**;AUG 13, 1993
+2 ;
DEF(SDPSODFN) ;Pass in Patient
+1 IF '$GET(SDPSODFN)!('$DATA(^DPT(SDPSODFN,0)))
QUIT 0
+2 NEW DA,DR,DIC,DIE,DIQ,X,Y,SDPSODSS,SDPSOPRM,SDPSODFA,SDPSODF1,SDPSODF2,SDPSODF3,SDPSOPDF
+3 DO INIT
+4 DO PAT
+5 IF '$DATA(SDPSODFA)
QUIT 0
+6 SET (SDPSOPRM,SDPSOPDF)=0
+7 SET SDPSODF1=""
FOR
SET SDPSODF1=$ORDER(SDPSODFA(SDPSODF1))
if SDPSODF1=""!(SDPSOPRM)
QUIT
SET SDPSODF2=""
FOR
SET SDPSODF2=$ORDER(SDPSODFA(SDPSODF1,SDPSODF2))
if SDPSODF2=""!(SDPSOPRM)
QUIT
Begin DoDot:1
+8 SET SDPSODF3=""
FOR
SET SDPSODF3=$ORDER(SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3))
if SDPSODF3=""!(SDPSOPRM)
QUIT
Begin DoDot:2
+9 IF SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3)
SET SDPSOPDF=SDPSODF2_"^"_SDPSODF3
SET SDPSOPRM=1
QUIT
+10 SET SDPSOPDF=SDPSODF2_"^"_SDPSODF3
End DoDot:2
End DoDot:1
+11 QUIT $SELECT(SDPSOPDF:SDPSOPDF,1:0)
INIT ;Initialize variables
+1 ;Create primary care DSS credit pair array
+2 NEW SDPSODI,SDPSODII
+3 FOR SDPSODI=322,323,350
FOR SDPSODII="000",185,186,187
SET SDPSODSS(SDPSODI_SDPSODII)=""
+4 QUIT
+5 ;
PAT ;
+1 NEW SDPSOSTA,SDPSOATZ,SDPSODIV,SDPSODCP,SDPSOCL0,SDPSOAP0,SDPSOSDT,SDPSOOUT,X,Y,X1,X2
+2 SET SDPSOOUT=0
+3 IF '$GET(DT)
SET DT=$$DT^XLFDT
+4 ;S X1=DT,X2=-1 D C^%DTC S SDPSOSDT=X_".2359"
+5 ;Call scheduling API for appointment information
+6 NEW SDPSOCNT,SDPSOSDI
+7 KILL ^TMP($JOB,"SDAMA201","GETAPPT")
+8 DO GETAPPT^SDAMA201(SDPSODFN,"1;2","R",DT,,.SDPSOCNT)
+9 IF $GET(SDPSOCNT)>0
Begin DoDot:1
+10 FOR SDPSOSDI=1:1:SDPSOCNT
SET SDPSOAP0=+$GET(^TMP($JOB,"SDAMA201","GETAPPT",SDPSOSDI,2))
Begin DoDot:2
+11 ;Q:$P(SDPSOAP0,U,2)["C" ;Skip cancelled appointments
+12 ;Get clinic 0 node
SET SDPSOCL0=$GET(^SC(+SDPSOAP0,0))
if '$LENGTH(SDPSOCL0)
QUIT
+13 ;Get DSS credit pair
SET SDPSODCP=$$CPAIR(SDPSOCL0)
+14 ;Get clinic division
SET SDPSODIV=$$DIV(SDPSOCL0)
+15 KILL SDPSOSTA
IF $GET(SDPSODIV)
KILL SDPSOATZ,DIC,DIQ,DD,DR
SET DIC=4
SET DR="99"
SET DA=+SDPSODIV
SET DIQ(0)="I"
SET DIQ="SDPSOATZ"
DO EN^DIQ1
SET SDPSOSTA=$GET(SDPSOATZ(4,+SDPSODIV,99,"I"))
KILL DIC,DIQ,DR,DA,SDPSOATZ
+16 IF SDPSODIV>0
IF $GET(SDPSOSTA)'=""
Begin DoDot:3
+17 SET SDPSOSDT=$PIECE($GET(^TMP($JOB,"SDAMA201","GETAPPT",SDPSOSDI,1)),"^")
IF SDPSOSDT
Begin DoDot:4
+18 SET SDPSODFA(SDPSOSDT,SDPSODIV,SDPSOSTA)=$SELECT($DATA(SDPSODSS(SDPSODCP)):1,1:0)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 KILL ^TMP($JOB,"SDAMA201","GETAPPT")
+20 QUIT
+21 ;
CPAIR(SDPSOCL0) ;Get credit pair
+1 NEW SDPSOSDX
+2 SET SDPSOSDX=$PIECE($GET(^DIC(40.7,+$PIECE(SDPSOCL0,U,7),0)),U,2)
+3 SET SDPSOSDX=SDPSOSDX_$PIECE($GET(^DIC(40.7,+$PIECE(SDPSOCL0,U,18),0)),U,2)
+4 SET SDPSOSDX=$EXTRACT(SDPSOSDX_"000000",1,6)
+5 QUIT SDPSOSDX
+6 ;
DIV(SDPSOCL0) ;Get facility division name and number
+1 NEW SDPSODVX,SDPSOHLD
SET SDPSODVX=$PIECE(SDPSOCL0,U,15)
+2 SET SDPSOHLD=0
+3 IF SDPSODVX>0
SET SDPSOHLD=$PIECE($$SITE^VASITE(,SDPSODVX),U)
+4 IF SDPSOHLD>0
QUIT SDPSOHLD
+5 SET SDPSOHLD=$PIECE(SDPSOCL0,"^",4)
+6 IF 'SDPSOHLD
QUIT 0
+7 IF SDPSOHLD
KILL ^UTILITY("DIQ1",$JOB),DIQ
SET DA=SDPSOHLD
SET DIC=4
SET DIQ(0)="E"
SET DR=".01"
DO EN^DIQ1
if $GET(^UTILITY("DIQ1",$JOB,4,DA,.01,"E"))=""
SET SDPSOHLD=0
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC,DIQ
+8 QUIT SDPSOHLD
+9 ;
PRIAPT(SDPSOPAT) ;Find nearest Primary care appt, past or future
+1 IF '$GET(DT)
SET DT=$$DT^XLFDT
+2 IF '$GET(SDPSOPAT)
QUIT ""
+3 NEW SDPSODSS,X1,X2,X,Y
+4 DO INIT
+5 NEW SDPSOQEC,SDPSOX,SDPSOX1,SDPSOX2,SDPSOX3,SDPSOX4,SDPSOX5,SDPSOX6,SDPSOX7,SDPSOX8,SDPSOX9,SDPSOX10,SDPSOX11,SDPSOX12,SDPSOX13,SDPSOX14,SDPSOX15
+6 SET SDPSOX=" "
+7 SET SDPSOQEC=0
+8 FOR
SET SDPSOX=$ORDER(^SCE("ADFN",SDPSOPAT,SDPSOX),-1)
SET SDPSOX1=0
if 'SDPSOX!(SDPSOQEC)!(SDPSOX<3030725)
QUIT
FOR
SET SDPSOX1=$ORDER(^SCE("ADFN",SDPSOPAT,SDPSOX,SDPSOX1))
if 'SDPSOX1!(SDPSOQEC)
QUIT
Begin DoDot:1
+9 SET SDPSOX2=$GET(^SCE(SDPSOX1,0))
if '$LENGTH(SDPSOX2)
QUIT
+10 if $PIECE(SDPSOX2,"^",6)
QUIT
+11 if '$PIECE(SDPSOX2,"^",4)
QUIT
+12 ;next line, checking for only "CHECKED OUT" and INPATIENT encounters
+13 IF $PIECE(SDPSOX2,"^",12)'=2
IF $PIECE(SDPSOX2,"^",12)'=8
QUIT
+14 SET SDPSOX3=$GET(^SC(+$PIECE(SDPSOX2,"^",4),0))
if '$LENGTH(SDPSOX3)
QUIT
+15 SET SDPSOX4=$$CPAIR(SDPSOX3)
+16 if '$DATA(SDPSODSS(SDPSOX4))
QUIT
+17 SET SDPSOX5(SDPSOPAT,"ENC")=SDPSOX_"^"_+$PIECE(SDPSOX2,"^",4)
SET SDPSOQEC=1
End DoDot:1
+18 ;S X1=DT,X2=-1 D C^%DTC S SDPSOX6=X_.2359
+19 NEW SDPSOCOU,SDPSODSI
+20 KILL ^TMP($JOB,"SDAMA201","GETAPPT")
+21 DO GETAPPT^SDAMA201(SDPSOPAT,"1;2","R",DT,,.SDPSOCOU)
+22 IF $GET(SDPSOCOU)>0
Begin DoDot:1
+23 FOR SDPSODSI=1:1:SDPSOCOU
SET SDPSOX7=+$GET(^TMP($JOB,"SDAMA201","GETAPPT",SDPSODSI,2))
if $DATA(SDPSOX10(SDPSOPAT,"APP"))
QUIT
Begin DoDot:2
+24 ;Q:$P(SDPSOX7,"^",2)["C"
+25 SET SDPSOX8=$GET(^SC(+SDPSOX7,0))
if '$LENGTH(SDPSOX8)
QUIT
+26 SET SDPSOX9=$$CPAIR(SDPSOX8)
+27 if '$DATA(SDPSODSS(SDPSOX9))
QUIT
+28 SET SDPSOX6=$PIECE($GET(^TMP($JOB,"SDAMA201","GETAPPT",SDPSODSI,1)),"^")
+29 IF '$DATA(SDPSOX10(SDPSOPAT,"APP"))
SET SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7
QUIT
+30 IF SDPSOX6<$PIECE($GET(SDPSOX10(SDPSOPAT,"APP")),"^")
SET SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7
End DoDot:2
End DoDot:1
+31 KILL ^TMP($JOB,"SDAMA201","GETAPPT")
+32 IF '$DATA(SDPSOX10(SDPSOPAT,"APP"))
IF '$DATA(SDPSOX5(SDPSOPAT,"ENC"))
QUIT ""
+33 IF $DATA(SDPSOX10(SDPSOPAT,"APP"))
IF '$DATA(SDPSOX5(SDPSOPAT,"ENC"))
DO APPX
QUIT SDPSOX11
+34 IF $DATA(SDPSOX5(SDPSOPAT,"ENC"))
IF '$DATA(SDPSOX10(SDPSOPAT,"APP"))
DO APPE
QUIT SDPSOX11
+35 SET SDPSOX12=$PIECE(SDPSOX10(SDPSOPAT,"APP"),"^")
SET SDPSOX14=$$FMDIFF^XLFDT(SDPSOX12,DT,1)
+36 SET SDPSOX12=$PIECE(SDPSOX5(SDPSOPAT,"ENC"),"^")
if SDPSOX12<0
SET SDPSOX12=$EXTRACT(SDPSOX12,2,$LENGTH(SDPSOX12))
SET SDPSOX15=$$FMDIFF^XLFDT(DT,SDPSOX12,1)
+37 ;Encounter wins ties
+38 IF SDPSOX14=SDPSOX15
DO APPE
QUIT SDPSOX11
+39 IF SDPSOX15>SDPSOX14
DO APPX
QUIT SDPSOX11
+40 DO APPE
QUIT SDPSOX11
APPX ;
+1 SET Y=$PIECE(SDPSOX10(SDPSOPAT,"APP"),"^")
DO DD^%DT
SET SDPSOX11=Y_" "_$PIECE($GET(^SC(+$PIECE($GET(SDPSOX10(SDPSOPAT,"APP")),"^",2),0)),"^")
+2 SET SDPSOX12=$PIECE(SDPSOX10(SDPSOPAT,"APP"),"^")
SET SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1)
SET SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
+3 QUIT
APPE ;
+1 SET Y=$PIECE(SDPSOX5(SDPSOPAT,"ENC"),"^")
DO DD^%DT
SET SDPSOX11=Y_" "_$PIECE($GET(^SC(+$PIECE($GET(SDPSOX5(SDPSOPAT,"ENC")),"^",2),0)),"^")
+2 SET SDPSOX12=$PIECE(SDPSOX5(SDPSOPAT,"ENC"),"^")
SET SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1)
SET SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
+3 QUIT
