source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDACSCGP.m@ 738

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1SDACSCGP ;ALB/TET - Print Computer Generated Appt Types or Stop Codes ;3/18/92 14:26
2 ;;5.3;Scheduling;**132,202**;Aug 13, 1993
3 ;
4 Q
5 ;
6EN ; -- print either CG stop codes or CG appt types
7 ; ('ag' or 'acg' cross ref)
8 ;
9 ; SDX=X-ref ACG=Computer Generated not resolved
10 ; AG =Computer Generated viits, all appointment types.
11 ;
12READ ;enter here to read
13 Q:'$D(SDX)
14 D ASK2^SDDIV G EXIT:Y<0
15 ;
16 S %H=+$H
17 D YX^%DTC
18 S %DT="AE"
19 S %DT("A")="Enter Beginning Date: "
20 S %DT("B")=Y
21 F D Q:X="^"!(Y>0)
22 .D ^%DT
23 .I Y>DT&(X'="^") D Q:X="^"!(Y>0)
24 ..W !,"You have entered a future or invalid date, please enter a valid date.",!
25 ..S Y=-1
26 .S:$D(DTOUT) X="^"
27 G:X="^" EXIT
28 K %DT
29 S SDBEG=Y
30 D DD^%DT S FR=Y
31 ;
32 S Y=DT D DD^%DT
33 S TO=Y
34 S %DT="AE"
35 S %DT("A")="Enter Ending Date ("_FR_" - "_TO_") "
36 S %DT("B")=Y
37 F D Q:X="^"!(Y>0)
38 .D ^%DT
39 .I Y<SDBEG&(X'="^") D Q
40 ..W !,"A date before the begin date is not allowed, please enter a valid date.",!
41 ..S Y=-1
42 .I Y>DT D Q
43 ..W !,"Future dates are not allowed, please enter a valid date.",!
44 ..S Y=-1
45 .I Y=-1&(X'="^") D Q
46 ..W !,"You have entered an invalid date, please enter a valid date."
47 .S:$D(DTOUT) X="^"
48 G:X="^" EXIT
49 S SDBEG=SDBEG-.0001
50 S SDEND=Y_".9999"
51 D DD^%DT S TO=Y
52 ;
53STOP ; -- one,many,all selection of stop codes
54 S VAUTNI=2
55 S VAUTSTR="clinic stop code"
56 S VAUTVB="SDC"
57 S DIC=40.7
58 D FIRST^VAUTOMA
59 G EXIT:Y<0
60 ;
61 S DGVAR="SDC#^SDBEG^SDEND^SDX^VAUTD#^TO^FR"
62 S DGPGM="QUE^SDACSCGP"
63 D ZIS^DGUTQ
64 G:POP EXIT
65 ;
66QUE ; -- entry point
67 N SDOE,SDOE0,SDOECG,DFN,SDDIV,SDT,SDSTOP,SDAPTYPR
68 S DASH="",$P(DASH,"-",79)=""
69 ;
70 I '$O(^SCE(SDX,0)) W !!?5,"There are no 'Computer Generated' ",$S(SDX="AG":"Stop Codes.",1:"Appointment Types which need updating.") G EXIT
71 ;
72 S SDT=SDBEG
73 F S SDT=$O(^SCE(SDX,SDT)) Q:'SDT!(SDT>SDEND) D
74 . S SDOE=0
75 . F S SDOE=$O(^SCE(SDX,SDT,SDOE)) Q:'SDOE D
76 . . S SDOE0=$G(^SCE(SDOE,0))
77 . . S SDOECG=$G(^SCE(SDOE,"CG"))
78 . . S SDDIV=+$P(SDOE0,U,11)
79 . . S DFN=+$P(SDOE0,U,2) D DEM^VADPT
80 . . I VAUTD!($D(VAUTD(SDDIV))) D
81 . . . S SDSTOP=$P(SDOE0,U,3)
82 . . . S SDAPTYPR=+$P(SDOECG,U,2)
83 . . . I SDC!($D(SDC(SDSTOP))) D SORT
84 ;
85PRINT ; -- loop thru division and stop code
86 S (PG,SDDIV)=0
87 F S SDDIV=$O(^TMP($J,SDDIV)) G:'SDDIV EXIT D:PG CR G:$D(DIRUT) EXIT D G:$D(DTOUT)!($D(DUOUT)) EXIT
88 . D DIV,HDR
89 . S SDSTOP=0
90 . F S SDSTOP=$O(^TMP($J,SDDIV,SDSTOP)) Q:'SDSTOP D SCHDR S CT=0 D P1 Q:$D(DTOUT)!($D(DUOUT)) D SCFTR Q:$D(DTOUT)!($D(DUOUT))
91 ;
92 ; -- loop thru tmp global - do write
93P1 S SDNAM=0
94 F S SDNAM=$O(^TMP($J,SDDIV,SDSTOP,SDNAM)) Q:SDNAM']"" D
95 . S SDSSN=""
96 . F S SDSSN=$O(^TMP($J,SDDIV,SDSTOP,SDNAM,SDSSN)) Q:SDSSN']"" D:$Y+6>IOSL CR,HDR Q:$D(DTOUT)!($D(DUOUT)) D DAT
97 Q
98 ;
99EXIT K CT,D,DA,DASH,DE,DFN,DGPGM,DGVAR,DIC,DIE,DIRUT,DQ,DR,DTOUT,DUOUT,I,L,POP,SDA,SDAPTYP,SDBEG,SDC,SDCSNODE,SDDAT,SDEND,SDI,SDJ,SDNAM,SDSSN,SDUPDT,SDX,SDY,SDZNODE,TYPE,VA,VADM,VAERR,VAUTD,Y
100 K FR,PG,TO,SDCSN,SDDIV,SDDIVNAM,SDHDR,SDSTOP,SDSTNUM,SDSTNAM,SDSTZ,VAUTNI,VAUTSTR,VAUTVB,^TMP($J)
101 D CLOSE^DGUTQ
102 Q
103 ;
104DAT ; -- get and print data
105 S SDDAT=0
106 F S SDDAT=$O(^TMP($J,SDDIV,SDSTOP,SDNAM,SDSSN,SDDAT)) Q:'SDDAT D
107 . N SDIEN
108 . S SDIEN=0
109 . F S SDIEN=$O(^TMP($J,SDDIV,SDSTOP,SDNAM,SDSSN,SDDAT,SDIEN)) Q:'SDIEN D
110 . . S SDAPTYPR=$G(^TMP($J,SDDIV,SDSTOP,SDNAM,SDSSN,SDDAT,SDIEN))
111 . . S Y=SDDAT X ^DD("DD")
112 . . S CT=CT+1
113 . . W !,$E(SDNAM,1,20),?25,SDSSN,?45,Y
114 . . W:SDX="ACG" ?70,$S(SDAPTYPR=2:"C&P",SDAPTYPR=1:"ELIG",1:"")
115 Q
116 ;
117SORT ; -- set tmp global to sort in alpha order by ssn & date, count sets
118 S CT=0
119 S SDNAM=$S('VAERR:VADM(1),1:"UNKNOWN")
120 S SDSSN=$S('VAERR:VA("PID"),1:"UNKNOWN")
121 S SDDIV=$S(+SDDIV:SDDIV,1:"UNKNOWN")
122 S SDSTOP=$S(+SDSTOP:SDSTOP,1:"UNKNOWN")
123 S ^TMP($J,SDDIV,SDSTOP,SDNAM,SDSSN,+SDOE0,SDOE)=SDAPTYPR
124 S CT=CT+1
125 Q
126 ;
127CR ; -- carriage return
128 I $D(IOST),$E(IOST,1,2)="C-" S DIR(0)="E" W ! D ^DIR Q:$D(DTOUT)!($D(DUOUT))
129 Q
130 ;
131DIV ; -- get division name for header
132 S SDDIVNAM=$S($D(^DG(40.8,+SDDIV,0)):$P(^(0),"^"),1:"UNKNOWN")
133 Q
134 ;
135HDR ; -- page header
136 S PG=PG+1
137 S SDHDR=$S(SDX="ACG":"APPOINTMENT TYPE",1:"STOP CODES")
138 W:$D(IOF) @IOF W !,?IOM-(11+$L(SDDIVNAM))/2,"DIVISION: ",SDDIVNAM,!,"COMPUTER GENERATED "_SDHDR,?40,FR," TO ",TO,?70,"PAGE ",PG,!,"PATIENT",?25,"PATIENT ID",?45,"VISIT DATE/TIME"
139 W:SDX="ACG" ?70,"REASON"
140 W !,DASH,!!
141 Q
142 ;
143SCHDR ; -- stop code header
144 S SDSTZ=$S($D(^DIC(40.7,+SDSTOP,0)):^(0),1:"")
145 S SDSTNAM=$S(SDSTZ]"":$P(SDSTZ,"^"),1:"UNKNOWN")
146 S SDSTNUM=$S(SDSTZ]"":$P(SDSTZ,"^",2),1:"000")
147 W !?3,"STOP CODE: ",SDSTNAM
148 Q
149 ;
150SCFTR ; -- footer
151 D:$Y+6>IOSL CR,HDR
152 Q:$D(DTOUT)!($D(DUOUT))
153 W !!,CT," Computer Generated ",$S(SDX="ACG":"Appointment Types ",1:"Stop Codes "),"for Stop Code, ",SDSTNUM,", ",SDSTNAM,!
154 Q
155 ;
156AG ; -- test ag
157 N SDX
158 S SDX="AG"
159 D EN
160 Q
161 ;
162ACG ; -- test ag
163 N SDX
164 S SDX="ACG"
165 D EN
166 Q
167 ;
Note: See TracBrowser for help on using the repository browser.