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

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

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1SDWLFUL1 ;;IOFO BAY PINES/TEH - REPAIR/RE-CAL ENROLLE STATUS;06/12/2002 ; 20 Aug 20022:10 PM
2 ;;5.3;scheduling;**525**;AUG 13 1993;Build 47
3 ;
4 ;
5 ;
6 ; TEMPORARY FILE:
7 ; 1ST PECE 3RD PIECE 4TH PIECE
8 ; ^SDWL(409.39,$J,EWL_IEN,PAT_IEN)=ENROLLE CAL TF ^ ENROLLE CAL API ^ ENROLLE CAL VSSC ^ CURRENT CAL
9 ;
10 ;
11 ;
12 ;
13 ;
14 ;
15 ;
16EN ;
17 I $D(^XTMP("SDWLFULSTAT",$J,3)) W !,"You have already run this OPTION." Q
18 I '$D(^XTMP("SDWLFULSTAT",$J,2)) W !,"You must run OPTION 2 before OPTION 3." Q
19 I '$D(^XTMP("SDWLFULSTAT",$J,"1B")) W !,"You must run a BACK-UP prior to running this option."
20 D SETUP S DAX=0 F S DAX=$O(^SDWL(409.3,DAX)) Q:DAX<1 D
21 .I $P(^SDWL(409.3,DAX,0),"^",2)>SDWLSDAT Q
22 .I $P(^SDWL(409.3,DAX,0),U,2)="" Q
23 .W !,DAX," of ",DAXT," records."
24 .S SDWLDFN=+$G(^SDWL(409.3,DAX,0)) I 'SDWLDFN Q
25 .S SDWLODT=$P(^SDWL(409.3,DAX,0),U,2),(SDWLODX,X)=SDWLODT D H^%DTC S SDWLODT=%H
26 .S SDWLEOLD=$P($G(^SDWL(409.3,DAX,0)),U,20)
27 .;NEW ENTRY
28 .S SDWLSSN=$$GET1^DIQ(2,SDWLDFN_",",.09)
29 .S X=SDWLDFN,DIC(0)="Z",DIC="^SDWL(409.39," D FILE^DICN S SDWLDA=+Y
30 .K DA,DIC,DR,DI,DIE,DO,Y
31 .S DA=SDWLDA,DR="9////^S X=DAX",DIE="^SDWL(409.39," D ^DIE
32 .S DR="4////^S X=SDWLEOLD" D ^DIE
33 .K DA,DIC,DR,DI,DIE,DO,X,Y
34 .S DIE="^SDWL(409.39,",DR="8////^S X=SDWLODX",DA=SDWLDA D ^DIE
35 .K DA,DIC,DR,DI,DO,X,Y
36 .S SDWLDE=SDWLODT,SDWLE=1,(SDWLEE,SDWLRNED,SDWLDB)=0
37 .D A0,SET
38 .D A1,SET
39 .D A2,SET
40 .S DIE="^SDWL(409.39,"
41 .S DA=SDWLDA,SDWLDB=4 S SDWLRNE=SDWLEOLD,DR=SDWLDB_"////^S X=SDWLRNE" D ^DIE
42 K DIE,DR,X,Y,DA,DAX,DIK,SDWLD,SDWLDA,SDWLDAT,SDWLDB,SDWLDE,SDWLDET,SDWLDFN
43 K SDWLDS,SDWLDTT,SDWLE,SDWLEE,SDWLEOLD,SDWLODT,SDWLODX,SDWLRNE,SDWLRNED,SDWLSDAT
44 K SDWLSSN,SDWLTDT,SDWLX,SDWLY,DAXT,%H,SDWLF,SDWLSET,SDWLXX
45 S ^XTMP("SDWLFULSTAT",$J,3)=""
46 Q
47SET S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U"),DIE="^SDWL(409.39,",DA=SDWLDA
48SET1 S DR=SDWLDB_"////^S X=SDWLRNE" D ^DIE
49SET2 S DR=SDWLDB+4_"////^S X=SDWLDAT" D ^DIE
50 S SDWLX=$G(^SDWL(409.39,SDWLDA,0)),SDWLF=0,SDWLSET=""
51 S SDWLXX=$P(SDWLX,"^",2,4) I SDWLXX["E" S SDWLSET="E" D SET3 S SDWLF=1 Q
52 I 'SDWLF,SDWLXX["P" S SDWLSET="P" D SET3 S SDWLF=1 Q
53 I 'SDWLF,SDWLXX["N" S SDWLSET="N" D SET3 S SDWLF=1 Q
54 I 'SDWLF S SDWLXX="U" S SDWLSET="U" D SET3 Q
55 Q
56SET3 S DR="8.1////^S X=SDWLSET",DIE=409.39,DA=SDWLDA D ^DIE
57 K DIE,DR,X,Y,DA
58 Q
59A0 ;GET TREATMENT DATE FROM TREATING FACILITY FILE
60 I '$D(^DGCN(391.91,"B",SDWLDFN)) S SDWLDB=1,SDWLDAT="" S SDWLE="" Q
61 S SDWLX="",SDWLDAT="",SDWLDB=1,SDWLE=1 F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D
62 .S SDWLY=$G(^DGCN(391.91,SDWLX,0)) D
63 ..;CHECK FOR VALID TF
64 ..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
65 ...;GET LIST OF DATES FOR TF
66 ...S SDWLD=$P(SDWLY,U,3) S X=SDWLD D H^%DTC I %H>SDWLODT S SDWLD=0 Q
67 ...I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
68 ;FIND LAST TREATMENT DATE
69 I '$D(SDWLDTF) Q
70 S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLDAT,X)=9999999-SDWLDTF D H^%DTC
71 S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2
72 I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
73 K SDWLDTF
74 Q
75A1 ;GET DATE FROM PATIENT ENROLLMENT
76 S SDWLDB=2,SDWLDAT="" G A1B:SDWLE=2
77 S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G A1A:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3) D
78 .S X=SDWLRNE D H^%DTC
79 .I %H>SDWLODT S SDWLRNED=0
80 I SDWLRNED S (SDWLDAT,X)=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=SDWLODT,SDWLDET=SDWLDE-SDWLDS,SDWLDB=2 I SDWLDET<366 S SDWLE=1
81 I $D(SDWLDET),SDWLDET>365 S SDWLE=3
82 I 'SDWLRNE S SDWLE=4
83A1A I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
84 .I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
85 .I 'SDWLEE S SDWLE=4 Q
86A1B Q
87A2 ;GET TREATMENT DATE FROM VSSC FILE
88 S SDWLDTT=SDWLODX,SDWLDE=SDWLODT,SDWLDB=3,SDWLDAT="",SDWLE="" D
89 .I '$D(^XTMP("SDWLFUL",$J,SDWLSSN,SDWLDTT)) Q
90 .S SDWLTDT=+$G(^XTMP("SDWLFUL",$J,SDWLSSN,SDWLDTT)),X=SDWLTDT D H^%DTC I %H'>SDWLODT D
91 ..S SDWLDAT=SDWLTDT,SDWLEE=SDWLDE-%H,SDWLDB=3 I SDWLEE<730 S SDWLE=2
92 ..I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
93 Q
94KILL S DA=0 F S DA=$O(^SDWL(409.39,DA)) Q:DA<1 S DIK="^SDWL(409.39," D ^DIK
95 Q
96SETUP S X=^DIC(409.39,0) K ^SDWL(409.39) S ^SDWL(409.39,0)=X
97 S SDWLX=$O(^XPD(9.7,"B","SD*5.3*485",999999999),-1)
98 S SDWLSDAT=+$P(^XPD(9.7,SDWLX,0),"^",3)
99 S DAXT=$P($G(^SDWL(409.3,0)),U,4)
Note: See TracBrowser for help on using the repository browser.