source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLBACC.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1SDWLBACC ;;IOFO BAY PINES/OG - BATCH CHANGE EWL CLINIC ; Compiled August 14, 2007 11:20:57
2 ;;5.3;scheduling;**446**;AUG 13 1993;Build 77
3 ;
4 ; ******************************************************************
5 ; CHANGE LOG
6 ;
7 ; DATE PATCH DESCRIPTION
8 ; ---- ----- -----------
9 ;
10 ;
11 N SDWLERR,SDWLOPT,SDWLSCL,SDWLHD,SDWLIN1,SDWLIN2,SDWLCL0,SDWLCL1,SDWLCL2,SDWLCSC1,SDWLCSC2,SDWLCM
12 S SDWLHD="Scheduling/PCMM Batch Change EWL Clinic"
13 W:$D(IOF) @IOF W !?80-$L(SDWLHD)\2,SDWLHD,!
14 S SDWLERR=0,SDWLOPT=1,(SDWLIN2,SDWLCL1,SDWLCL2,SDWLCM)="",SDWLIN1=+$$SITE^VASITE()
15 F D @("P"_SDWLOPT) Q:'SDWLOPT
16 Q
17P1 ; Source Institution
18 S DIR(0)="PAO^DIC(4,:EMNZ"
19 S DIR("A")="Select Source Institution: "
20 I SDWLIN1'="" S DIR("B")=$$GET1^DIQ(4,SDWLIN1,.01)
21 S DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
22 D ^DIR
23 I Y<1 S SDWLOPT=0 Q
24 S (SDWLIN1,SDWLIN2)=+Y,SDWLOPT=SDWLOPT+1
25 Q
26P2 ; Source Clinic
27 N DIR,SDWLSC
28 S DIR(0)="PAO^SDWL(409.32,:EMNZ"
29 S DIR("A")="Select Source Clinic: "
30 I SDWLCL1'="" S DIR("B")=$$GET1^DIQ(409.32,SDWLCL1,.01)
31 S DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN1"
32 D ^DIR
33 I Y="^" S SDWLOPT=0 Q
34 I Y<1 S SDWLOPT=SDWLOPT-1 Q
35 S SDWLCL0=+Y ; Wait list specific clinic
36 S SDWLCL1=$P(Y,U,2) ; pointer to HOSPITAL LOCATION file
37 S SDWLCSC1=$$GET1^DIQ(44,SDWLCL1,8,"I")_U_$$GET1^DIQ(44,SDWLCL1,8) ; Clinic stop code
38 S SDWLOPT=SDWLOPT+1
39 Q
40P3 ; Destination Institution
41 S DIR(0)="PAO^DIC(4,:EMNZ"
42 S DIR("A")="Select Destination Institution: "
43 I SDWLIN1'="" S DIR("B")=$$GET1^DIQ(4,SDWLIN2,.01)
44 S DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
45 D ^DIR
46 I Y="^" S SDWLOPT=0 Q
47 I Y<1 S SDWLOPT=SDWLOPT-1 Q
48 S SDWLIN2=+Y,SDWLOPT=SDWLOPT+1
49 Q
50P4 ; Destination Clinic
51 N DIR,SDWLSC,SDWLY
52 S DIR(0)="PAO^SDWL(409.32,:EMNZ"
53 S DIR("A")="Select Destination Clinic: "
54 I SDWLCL2'="" S DIR("B")=$$GET1^DIQ(409.32,SDWLCL2,.01)
55 S DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN2,+Y'=SDWLCL0"
56 D ^DIR
57 I Y="^" S SDWLOPT=0 Q
58 I Y<1 S SDWLOPT=SDWLOPT-1 Q
59 S SDWLY=+Y,SDWLSC=$P(Y,U,2) ; pointer to HOSPITAL LOCATION file
60 ; get clinic's stop code. warn if different.
61 S SDWLCSC2=$$GET1^DIQ(44,SDWLSC,8,"I")_U_$$GET1^DIQ(44,SDWLSC,8) ; Clinic's stop code
62 I +SDWLCSC1'=+SDWLCSC2 D Q:'Y
63 .S DIR(0)="Y"
64 .S DIR("A")="The clinics' stop codes are different, continue"
65 .S DIR("A",1)=$$GET1^DIQ(409.32,SDWLCL1,.01)_": "_$P(SDWLCSC1,U,2)_" ("_+SDWLCSC1_")"
66 .S DIR("A",2)=$$GET1^DIQ(409.32,+Y,.01)_": "_$P(SDWLCSC2,U,2)_" ("_+SDWLCSC2_")"
67 .S DIR("B")="YES"
68 .D ^DIR
69 .S:Y="^" SDWLOPT=0
70 .Q
71 S SDWLSCL=SDWLY,SDWLOPT=SDWLOPT+1
72 Q
73P5 ; Comment
74 D P4^SDWLE6
75 Q
76P6 ; Confirmation and processing
77 N DIR,Y
78 S DIR(0)="Y"
79 S DIR("A")="Proceed with batch clinic change"
80 S DIR("B")="YES"
81 D ^DIR
82 D:Y CHNGCL
83 S SDWLOPT=0
84 Q
85CHNGCL ;
86 N DIR,SDWLDA,SDWLCNT
87 S SDWLDA="",SDWLCNT=0
88 F S SDWLDA=$O(^SDWL(409.3,"SC",SDWLCL1,SDWLDA)) Q:'SDWLDA D
89 .N DA,DIE,DIR,DR,SDWLDFN,SDWLIN,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLCL1,SDWLDDT,SDWLEEST,Y
90 .D GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;23;27","I","SDWLTMP")
91 .Q:SDWLTMP(409.3,SDWLDA_",",23,"I")="C" ; Only open entries.
92 .S SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
93 .S SDWLORDT=SDWLTMP(409.3,SDWLDA_",",1,"I")
94 .S SDWLSCPG=SDWLTMP(409.3,SDWLDA_",",14,"I")
95 .S SDWLSCPR=SDWLTMP(409.3,SDWLDA_",",15,"I")
96 .S SDWLDDT=SDWLTMP(409.3,SDWLDA_",",22,"I")
97 .S SDWLEEST=SDWLTMP(409.3,SDWLDA_",",27,"I")
98 .Q:'$$UPDATE^SDWLE7(SDWLDFN,SDWLORDT,SDWLIN2,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA)
99 .; disposition old entry
100 .S DIE="^SDWL(409.3,",DA=SDWLDA,DR="19////^S X=DT;20////^S X=DUZ;21////^S X=""CL"";23////^S X=""C"""
101 .D ^DIE
102 .S SDWLCNT=SDWLCNT+1
103 .Q
104 W ! W:SDWLCNT "Clinics changed. " W SDWLCNT," entries processed."
105 S DIR(0)="E" D ^DIR
106 Q
107CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path.
108 ; function to return:
109 ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ Inst Name _U_ Div Pointer to ^DG(40.8 _U_N/L_U_Message
110 ; ( INST^STA NUM^SNAM^DIV^N/L^MESS )
111 ; N/L - N -National/L -Local
112 ; with Message:
113 ; - if STA="" INST^^SNAM^DIV^^N/L^' - No Station Number on file'
114 ; or
115 ; - 0^^^DIV^^' - No Institution has been identified'
116 ; - 0^^^-1^^' - no Division has been identified'
117 ; - -1 no clinic on file'
118 I '$D(^SC(+CL)) Q -1_"^^^^^no clinic on file"
119 N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN=""
120 S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
121 I DIV=0 S SDWMES="no Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES
122 S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
123 I INS=0 S SDWMES="No Institution has been identified" Q 0_"^^^"_DIV_"^"_SDWMES
124 E S STR=$$NS^XUAF4(INS),STN=$P(STR,U,2),SNAM=$P(STR,U) ;station number and name
125 I STN="" S SDWMES="No Station Number on file"
126 I '$$TF^XUAF4(INS) S SDWMES="Inactive treating medical facility"
127 S SNL=$$GET1^DIQ(4,INS_",",11,"I")
128 Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES
Note: See TracBrowser for help on using the repository browser.