source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDPHARM1.m@ 1710

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