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

Last change on this file since 699 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1SDPHARM1 ;BIRMINGHAM OIFO/RON - Determine default Institution/Station no. ; 8/9/03
2 ;;5.3;Scheduling;**300,314,318**;AUG 13, 1993
3 ;
4DEF(SDPSODFN) ;Pass in Patient
5 I '$G(SDPSODFN)!('$D(^DPT(SDPSODFN,0))) Q 0
6 N DA,DR,DIC,DIE,DIQ,X,Y,SDPSODSS,SDPSOPRM,SDPSODFA,SDPSODF1,SDPSODF2,SDPSODF3,SDPSOPDF
7 D INIT
8 D PAT
9 I '$D(SDPSODFA) Q 0
10 S (SDPSOPRM,SDPSOPDF)=0
11 S SDPSODF1="" F S SDPSODF1=$O(SDPSODFA(SDPSODF1)) Q:SDPSODF1=""!(SDPSOPRM) S SDPSODF2="" F S SDPSODF2=$O(SDPSODFA(SDPSODF1,SDPSODF2)) Q:SDPSODF2=""!(SDPSOPRM) D
12 .S SDPSODF3="" F S SDPSODF3=$O(SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3)) Q:SDPSODF3=""!(SDPSOPRM) D
13 ..I SDPSODFA(SDPSODF1,SDPSODF2,SDPSODF3) S SDPSOPDF=SDPSODF2_"^"_SDPSODF3,SDPSOPRM=1 Q
14 ..S SDPSOPDF=SDPSODF2_"^"_SDPSODF3
15 Q $S(SDPSOPDF:SDPSOPDF,1:0)
16INIT ;Initialize variables
17 ;Create primary care DSS credit pair array
18 N SDPSODI,SDPSODII
19 F SDPSODI=322,323,350 F SDPSODII="000",185,186,187 S SDPSODSS(SDPSODI_SDPSODII)=""
20 Q
21 ;
22PAT ;
23 N SDPSOSTA,SDPSOATZ,SDPSODIV,SDPSODCP,SDPSOCL0,SDPSOAP0,SDPSOSDT,SDPSOOUT,X,Y,X1,X2
24 S SDPSOOUT=0
25 I '$G(DT) S DT=$$DT^XLFDT
26 ;S X1=DT,X2=-1 D C^%DTC S SDPSOSDT=X_".2359"
27 ;Call scheduling API for appointment information
28 N SDPSOCNT,SDPSOSDI
29 K ^TMP($J,"SDAMA201","GETAPPT")
30 D GETAPPT^SDAMA201(SDPSODFN,"1;2","R",DT,,.SDPSOCNT)
31 I $G(SDPSOCNT)>0 D
32 .F SDPSOSDI=1:1:SDPSOCNT S SDPSOAP0=+$G(^TMP($J,"SDAMA201","GETAPPT",SDPSOSDI,2)) D
33 ..;Q:$P(SDPSOAP0,U,2)["C" ;Skip cancelled appointments
34 ..S SDPSOCL0=$G(^SC(+SDPSOAP0,0)) Q:'$L(SDPSOCL0) ;Get clinic 0 node
35 ..S SDPSODCP=$$CPAIR(SDPSOCL0) ;Get DSS credit pair
36 ..S SDPSODIV=$$DIV(SDPSOCL0) ;Get clinic division
37 ..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
38 ..I SDPSODIV>0,$G(SDPSOSTA)'="" D
39 ...S SDPSOSDT=$P($G(^TMP($J,"SDAMA201","GETAPPT",SDPSOSDI,1)),"^") I SDPSOSDT D
40 ....S SDPSODFA(SDPSOSDT,SDPSODIV,SDPSOSTA)=$S($D(SDPSODSS(SDPSODCP)):1,1:0)
41 K ^TMP($J,"SDAMA201","GETAPPT")
42 Q
43 ;
44CPAIR(SDPSOCL0) ;Get credit pair
45 N SDPSOSDX
46 S SDPSOSDX=$P($G(^DIC(40.7,+$P(SDPSOCL0,U,7),0)),U,2)
47 S SDPSOSDX=SDPSOSDX_$P($G(^DIC(40.7,+$P(SDPSOCL0,U,18),0)),U,2)
48 S SDPSOSDX=$E(SDPSOSDX_"000000",1,6)
49 Q SDPSOSDX
50 ;
51DIV(SDPSOCL0) ;Get facility division name and number
52 N SDPSODVX,SDPSOHLD S SDPSODVX=$P(SDPSOCL0,U,15)
53 S SDPSOHLD=0
54 I SDPSODVX>0 S SDPSOHLD=$P($$SITE^VASITE(,SDPSODVX),U)
55 I SDPSOHLD>0 Q SDPSOHLD
56 S SDPSOHLD=$P(SDPSOCL0,"^",4)
57 I 'SDPSOHLD Q 0
58 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
59 Q SDPSOHLD
60 ;
61PRIAPT(SDPSOPAT) ;Find nearest Primary care appt, past or future
62 I '$G(DT) S DT=$$DT^XLFDT
63 I '$G(SDPSOPAT) Q ""
64 N SDPSODSS,X1,X2,X,Y
65 D INIT
66 N SDPSOQEC,SDPSOX,SDPSOX1,SDPSOX2,SDPSOX3,SDPSOX4,SDPSOX5,SDPSOX6,SDPSOX7,SDPSOX8,SDPSOX9,SDPSOX10,SDPSOX11,SDPSOX12,SDPSOX13,SDPSOX14,SDPSOX15
67 S SDPSOX=" "
68 S SDPSOQEC=0
69 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
70 .S SDPSOX2=$G(^SCE(SDPSOX1,0)) Q:'$L(SDPSOX2)
71 .Q:$P(SDPSOX2,"^",6)
72 .Q:'$P(SDPSOX2,"^",4)
73 .;next line, checking for only "CHECKED OUT" and INPATIENT encounters
74 .I $P(SDPSOX2,"^",12)'=2,$P(SDPSOX2,"^",12)'=8 Q
75 .S SDPSOX3=$G(^SC(+$P(SDPSOX2,"^",4),0)) Q:'$L(SDPSOX3)
76 .S SDPSOX4=$$CPAIR(SDPSOX3)
77 .Q:'$D(SDPSODSS(SDPSOX4))
78 .S SDPSOX5(SDPSOPAT,"ENC")=SDPSOX_"^"_+$P(SDPSOX2,"^",4),SDPSOQEC=1
79 ;S X1=DT,X2=-1 D C^%DTC S SDPSOX6=X_.2359
80 N SDPSOCOU,SDPSODSI
81 K ^TMP($J,"SDAMA201","GETAPPT")
82 D GETAPPT^SDAMA201(SDPSOPAT,"1;2","R",DT,,.SDPSOCOU)
83 I $G(SDPSOCOU)>0 D
84 .F SDPSODSI=1:1:SDPSOCOU S SDPSOX7=+$G(^TMP($J,"SDAMA201","GETAPPT",SDPSODSI,2)) Q:$D(SDPSOX10(SDPSOPAT,"APP")) D
85 ..;Q:$P(SDPSOX7,"^",2)["C"
86 ..S SDPSOX8=$G(^SC(+SDPSOX7,0)) Q:'$L(SDPSOX8)
87 ..S SDPSOX9=$$CPAIR(SDPSOX8)
88 ..Q:'$D(SDPSODSS(SDPSOX9))
89 ..S SDPSOX6=$P($G(^TMP($J,"SDAMA201","GETAPPT",SDPSODSI,1)),"^")
90 ..I '$D(SDPSOX10(SDPSOPAT,"APP")) S SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7 Q
91 ..I SDPSOX6<$P($G(SDPSOX10(SDPSOPAT,"APP")),"^") S SDPSOX10(SDPSOPAT,"APP")=SDPSOX6_"^"_+SDPSOX7
92 K ^TMP($J,"SDAMA201","GETAPPT")
93 I '$D(SDPSOX10(SDPSOPAT,"APP")),'$D(SDPSOX5(SDPSOPAT,"ENC")) Q ""
94 I $D(SDPSOX10(SDPSOPAT,"APP")),'$D(SDPSOX5(SDPSOPAT,"ENC")) D APPX Q SDPSOX11
95 I $D(SDPSOX5(SDPSOPAT,"ENC")),'$D(SDPSOX10(SDPSOPAT,"APP")) D APPE Q SDPSOX11
96 S SDPSOX12=$P(SDPSOX10(SDPSOPAT,"APP"),"^"),SDPSOX14=$$FMDIFF^XLFDT(SDPSOX12,DT,1)
97 S SDPSOX12=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") S:SDPSOX12<0 SDPSOX12=$E(SDPSOX12,2,$L(SDPSOX12)) S SDPSOX15=$$FMDIFF^XLFDT(DT,SDPSOX12,1)
98 ;Encounter wins ties
99 I SDPSOX14=SDPSOX15 D APPE Q SDPSOX11
100 I SDPSOX15>SDPSOX14 D APPX Q SDPSOX11
101 D APPE Q SDPSOX11
102APPX ;
103 S Y=$P(SDPSOX10(SDPSOPAT,"APP"),"^") D DD^%DT S SDPSOX11=Y_" "_$P($G(^SC(+$P($G(SDPSOX10(SDPSOPAT,"APP")),"^",2),0)),"^")
104 S SDPSOX12=$P(SDPSOX10(SDPSOPAT,"APP"),"^") S SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1) S SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
105 Q
106APPE ;
107 S Y=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") D DD^%DT S SDPSOX11=Y_" "_$P($G(^SC(+$P($G(SDPSOX5(SDPSOPAT,"ENC")),"^",2),0)),"^")
108 S SDPSOX12=$P(SDPSOX5(SDPSOPAT,"ENC"),"^") S SDPSOX13=$$FMDIFF^XLFDT(SDPSOX12,DT,1) S SDPSOX11=SDPSOX11_" ("_SDPSOX13_" days)"
109 Q
Note: See TracBrowser for help on using the repository browser.