Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDPHARM1

SDPHARM1.m

Go to the documentation of this file.
  1. SDPHARM1 ;BIRMINGHAM OIFO/RON - Determine default Institution/Station no. ; 8/9/03
  1. ;;5.3;Scheduling;**300,314,318**;AUG 13, 1993
  1. ;
  1. DEF(SDPSODFN) ;Pass in Patient
  1. I '$G(SDPSODFN)!('$D(^DPT(SDPSODFN,0))) Q 0
  1. N DA,DR,DIC,DIE,DIQ,X,Y,SDPSODSS,SDPSOPRM,SDPSODFA,SDPSODF1,SDPSODF2,SDPSODF3,SDPSOPDF
  1. D INIT
  1. D PAT
  1. I '$D(SDPSODFA) Q 0
  1. S (SDPSOPRM,SDPSOPDF)=0
  1. S SDPSODF1="" F S SDPSODF1=$O(SDPSODFA(SDPSODF1)) Q:SDPSODF1=""!(SDPSOPRM) S SDPSODF2="" F S SDPSODF2=$O(SDPSODFA(SDPSODF1,SDPSODF2)) Q:SDPSODF2=""!(SDPSOPRM) D
  1. .S SDPSODF3="" F S SDPSODF3=$O(SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3)) Q:SDPSODF3=""!(SDPSOPRM) D
  1. ..I SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3) S SDPSOPDF=SDPSODF2_"^"_SDPSODF3,SDPSOPRM=1 Q
  1. ..S SDPSOPDF=SDPSODF2_"^"_SDPSODF3
  1. Q $S(SDPSOPDF:SDPSOPDF,1:0)
  1. INIT ;Initialize variables
  1. ;Create primary care DSS credit pair array
  1. N SDPSODI,SDPSODII
  1. F SDPSODI=322,323,350 F SDPSODII="000",185,186,187 S SDPSODSS(SDPSODI_SDPSODII)=""
  1. Q
  1. ;
  1. PAT ;
  1. N SDPSOSTA,SDPSOATZ,SDPSODIV,SDPSODCP,SDPSOCL0,SDPSOAP0,SDPSOSDT,SDPSOOUT,X,Y,X1,X2
  1. S SDPSOOUT=0
  1. I '$G(DT) S DT=$$DT^XLFDT
  1. ;S X1=DT,X2=-1 D C^%DTC S SDPSOSDT=X_".2359"
  1. ;Call scheduling API for appointment information
  1. N SDPSOCNT,SDPSOSDI
  1. K ^TMP($J,"SDAMA201","GETAPPT")
  1. D GETAPPT^SDAMA201(SDPSODFN,"1;2","R",DT,,.SDPSOCNT)
  1. I $G(SDPSOCNT)>0 D
  1. .F SDPSOSDI=1:1:SDPSOCNT S SDPSOAP0=+$G(^TMP($J,"SDAMA201","GETAPPT",SDPSOSDI,2)) D
  1. ..;Q:$P(SDPSOAP0,U,2)["C" ;Skip cancelled appointments
  1. ..S SDPSOCL0=$G(^SC(+SDPSOAP0,0)) Q:'$L(SDPSOCL0) ;Get clinic 0 node
  1. ..S SDPSODCP=$$CPAIR(SDPSOCL0) ;Get DSS credit pair
  1. ..S SDPSODIV=$$DIV(SDPSOCL0) ;Get clinic division
  1. ..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
  1. ..I SDPSODIV>0,$G(SDPSOSTA)'="" D
  1. ...S SDPSOSDT=$P($G(^TMP($J,"SDAMA201","GETAPPT",SDPSOSDI,1)),"^") I SDPSOSDT D
  1. ....S SDPSODFA(SDPSOSDT,SDPSODIV,SDPSOSTA)=$S($D(SDPSODSS(SDPSODCP)):1,1:0)
  1. K ^TMP($J,"SDAMA201","GETAPPT")
  1. Q
  1. ;
  1. CPAIR(SDPSOCL0) ;Get credit pair
  1. N SDPSOSDX
  1. S SDPSOSDX=$P($G(^DIC(40.7,+$P(SDPSOCL0,U,7),0)),U,2)
  1. S SDPSOSDX=SDPSOSDX_$P($G(^DIC(40.7,+$P(SDPSOCL0,U,18),0)),U,2)
  1. S SDPSOSDX=$E(SDPSOSDX_"000000",1,6)
  1. Q SDPSOSDX
  1. ;
  1. DIV(SDPSOCL0) ;Get facility division name and number
  1. N SDPSODVX,SDPSOHLD S SDPSODVX=$P(SDPSOCL0,U,15)
  1. S SDPSOHLD=0
  1. I SDPSODVX>0 S SDPSOHLD=$P($$SITE^VASITE(,SDPSODVX),U)
  1. I SDPSOHLD>0 Q SDPSOHLD
  1. S SDPSOHLD=$P(SDPSOCL0,"^",4)
  1. I 'SDPSOHLD Q 0
  1. 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
  1. Q SDPSOHLD
  1. ;
  1. PRIAPT(SDPSOPAT) ;Find nearest Primary care appt, past or future
  1. I '$G(DT) S DT=$$DT^XLFDT
  1. I '$G(SDPSOPAT) Q ""
  1. N SDPSODSS,X1,X2,X,Y
  1. D INIT
  1. N SDPSOQEC,SDPSOX,SDPSOX1,SDPSOX2,SDPSOX3,SDPSOX4,SDPSOX5,SDPSOX6,SDPSOX7,SDPSOX8,SDPSOX9,SDPSOX10,SDPSOX11,SDPSOX12,SDPSOX13,SDPSOX14,SDPSOX15
  1. S SDPSOX=" "
  1. S SDPSOQEC=0
  1. 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
  1. .S SDPSOX2=$G(^SCE(SDPSOX1,0)) Q:'$L(SDPSOX2)
  1. .Q:$P(SDPSOX2,"^",6)
  1. .Q:'$P(SDPSOX2,"^",4)
  1. .;next line, checking for only "CHECKED OUT" and INPATIENT encounters
  1. .I $P(SDPSOX2,"^",12)'=2,$P(SDPSOX2,"^",12)'=8 Q
  1. .S SDPSOX3=$G(^SC(+$P(SDPSOX2,"^",4),0)) Q:'$L(SDPSOX3)
  1. .S SDPSOX4=$$CPAIR(SDPSOX3)
  1. .Q:'$D(SDPSODSS(SDPSOX4))
  1. .S SDPSOX5(SDPSOPAT,"ENC")=SDPSOX_"^"_+$P(SDPSOX2,"^",4),SDPSOQEC=1
  1. ;S X1=DT,X2=-1 D C^%DTC S SDPSOX6=X_.2359
  1. N SDPSOCOU,SDPSODSI
  1. K ^TMP($J,"SDAMA201","GETAPPT")
  1. D GETAPPT^SDAMA201(SDPSOPAT,"1;2","R",DT,,.SDPSOCOU)
  1. I $G(SDPSOCOU)>0 D
  1. .F SDPSODSI=1:1:SDPSOCOU S SDPSOX7=+$G(^TMP($J,"SDAMA201","GETAPPT",SDPSODSI,2)) Q:$D(SDPSOX10(SDPSOPAT,"APP")) D
  1. ..;Q:$P(SDPSOX7,"^",2)["C"
  1. ..S SDPSOX8=$G(^SC(+SDPSOX7,0)) Q:'$L(SDPSOX8)
  1. ..S SDPSOX9=$$CPAIR(SDPSOX8)
  1. ..Q:'$D(SDPSODSS(SDPSOX9))
  1. ..S SDPSOX6=$P($G(^TMP($J,"SDAMA201","GETAPPT",SDPSODSI,1)),"^")
  1. ..I '$D(SDPSOX10(SDPSOPAT,"APP")) S SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7 Q
  1. ..I SDPSOX6<$P($G(SDPSOX10(SDPSOPAT,"APP")),"^") S SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7
  1. K ^TMP($J,"SDAMA201","GETAPPT")
  1. I '$D(SDPSOX10(SDPSOPAT,"APP")),'$D(SDPSOX5(SDPSOPAT,"ENC")) Q ""
  1. I $D(SDPSOX10(SDPSOPAT,"APP")),'$D(SDPSOX5(SDPSOPAT,"ENC")) D APPX Q SDPSOX11
  1. I $D(SDPSOX5(SDPSOPAT,"ENC")),'$D(SDPSOX10(SDPSOPAT,"APP")) D APPE Q SDPSOX11
  1. S SDPSOX12=$P(SDPSOX10(SDPSOPAT,"APP"),"^"),SDPSOX14=$$FMDIFF^XLFDT(SDPSOX12,DT,1)
  1. S SDPSOX12=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") S:SDPSOX12<0 SDPSOX12=$E(SDPSOX12,2,$L(SDPSOX12)) S SDPSOX15=$$FMDIFF^XLFDT(DT,SDPSOX12,1)
  1. ;Encounter wins ties
  1. I SDPSOX14=SDPSOX15 D APPE Q SDPSOX11
  1. I SDPSOX15>SDPSOX14 D APPX Q SDPSOX11
  1. D APPE Q SDPSOX11
  1. APPX ;
  1. S Y=$P(SDPSOX10(SDPSOPAT,"APP"),"^") D DD^%DT S SDPSOX11=Y_" "_$P($G(^SC(+$P($G(SDPSOX10(SDPSOPAT,"APP")),"^",2),0)),"^")
  1. S SDPSOX12=$P(SDPSOX10(SDPSOPAT,"APP"),"^") S SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1) S SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
  1. Q
  1. APPE ;
  1. S Y=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") D DD^%DT S SDPSOX11=Y_" "_$P($G(^SC(+$P($G(SDPSOX5(SDPSOPAT,"ENC")),"^",2),0)),"^")
  1. S SDPSOX12=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") S SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1) S SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
  1. Q