source: FOIAVistA/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNPRT07.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1SPNPRT07 ;HIRMFO/WAA- PRINT Possible Reg. Based on D/C ;10/25/96 11:30
2 ;;2.0;Spinal Cord Dysfunction;**11,13**;01/02/1997
3 ;;
4EN1 ; Main Entry Point
5 N SPNLEXIT,SPNIO,SPNPAGE,SPNDATE,SPNEDAT S SPNPAGE=1
6 S SPNLEXIT=0
7 S SPNA=" Enter START Date: "
8 S SPNQ=" Enter the earliest date of Discharge for the print to START with."
9 D QUEST^SPNPRT04("DA^:NOW:EP",SPNA,SPNQ) Q:SPNLEXIT
10 S SPNDATE=Y
11 S ZTSAVE("SPN*")=""
12 S SPNA=" Enter END Date: "
13 S SPNQ=" Enter the latest date of Discharge for the print to END with."
14 D QUEST^SPNPRT04("DA^"_SPNDATE_":NOW:EP",SPNA,SPNQ) Q:SPNLEXIT
15 S SPNEDAT=Y
16 D DEVICE^SPNPRTMT("PRINT^SPNPRT07","SCD/SCI Discharges Patients",.ZTSAVE) Q:SPNLEXIT
17 I SPNIO="Q" D EXIT Q ; Print was Queued
18 I IO'="" D PRINT D EXIT Q ; Print was not Queued
19 Q
20EXIT ; Exit routine
21 K ^TMP($J,"SPN"),^TMP($J,"SPNPRT","AUTO"),^TMP($J,"SPNPRT","POST")
22 K SPNDATE
23 Q
24PRINT ; Print main Body
25 U IO
26 K ^TMP($J,"SPN")
27 S SPNLEXIT=$G(SPNLEXIT,0) ; Ensure that the exit is set
28 N SPNDFN,SPNX,SPNFAC
29 S (SPNDFN,SPNLPRT,SPNFAC)=0
30 S SPNQDAT=SPNDATE-.000001
31 Q:SPNLEXIT
32 F S SPNQDAT=$O(^DGPM("AMV3",SPNQDAT)) Q:(SPNQDAT<1) Q:(SPNQDAT>SPNEDAT) D Q:SPNLEXIT
33 . S SPNDFN=0
34 . F S SPNDFN=$O(^DGPM("AMV3",SPNQDAT,SPNDFN)) Q:SPNDFN<1 D Q:SPNLEXIT
35 .. S SPNIEN=0 F S SPNIEN=$O(^DGPM("AMV3",SPNQDAT,SPNDFN,SPNIEN)) Q:SPNIEN<1 D Q:SPNLEXIT
36 ... N DFN,SPNLINE,SPNLOS
37 ... I '$D(^SPNL(154,SPNDFN,0)),'(+$$GET1^DIQ(2,SPNDFN,57.4,"I")) Q
38 ... S DFN=SPNDFN,VAIP("E")=SPNIEN D IN5^VADPT
39 ... S SPNLOS=$$FMDIFF^XLFDT(SPNQDAT,$P(VAIP(15,1),U)) ; LENGTH OF STAY
40 ... ; SPNLINE=Movement date(E)^pointer to PTF(I)^Length of Stay
41 ... ; ^Ward location(E)^D/C date
42 ... S SPNLINE=$P(VAIP(15,1),U)_U_VAIP(12)_U_SPNLOS_U_$P(VAIP(5),U,2)_U_SPNQDAT
43 ... S ^TMP($J,"SPN",$$GET1^DIQ(2,SPNDFN,.01,"E"),SPNDFN,SPNIEN)=SPNLINE
44 ... D KVAR^VADPT
45 ... Q
46 .. Q
47 . Q
48 I $D(^TMP($J,"SPN")) D Q:SPNLEXIT ; Indicates the report had data
49 . N SPNSTATE,SPNDFN,SPNNAME,SPNCOU
50 . S SPNCOU=0
51 . S SPNNAME="" F S SPNNAME=$O(^TMP($J,"SPN",SPNNAME)) Q:SPNNAME="" D Q:SPNLEXIT
52 .. S SPNDFN=0 F S SPNDFN=$O(^TMP($J,"SPN",SPNNAME,SPNDFN)) Q:SPNDFN<1 D NEWPAT(SPNDFN) Q:SPNLEXIT D Q:SPNLEXIT W !
53 ... S SPNIEN=0 F S SPNIEN=$O(^TMP($J,"SPN",SPNNAME,SPNDFN,SPNIEN)) Q:SPNIEN<1 D Q:SPNLEXIT
54 .... S SPNLINE=^TMP($J,"SPN",SPNNAME,SPNDFN,SPNIEN)
55 ... D HEAD Q:SPNLEXIT
56 ... D PATIENT(SPNDFN,SPNLINE) Q:SPNLEXIT
57 ... Q
58 .. Q
59 .I SPNCOU D
60 .. W !,?15,SPNCOU," Patients have been processed."
61 .. I SPNFAC D RECFAC
62 .. Q
63 . Q
64 E W !," ******* No Data for this report. *******"
65 I $E(IOST,1)="C" N DIR S DIR(0)="E" D ^DIR K Y
66 D CLOSE^SPNPRTMT
67 K ^TMP($J,"SPN")
68 Q
69RECFAC ; Print out a frequency table for receiving facilities
70 S SPNPAGE=1
71 N SPNFACN
72 S SPNFACN=0
73 F S SPNFACN=$O(SPNFAC(SPNFACN)) Q:SPNFACN<1 D Q:SPNLEXIT
74 . N SPNIEN
75 . S SPNIEN=0
76 . F S SPNIEN=$O(^DIC(4,"D",SPNFACN,SPNIEN)) Q:SPNIEN<1 D Q:SPNLEXIT
77 .. Q:$G(^DIC(4,SPNIEN,0))=""
78 .. D HEAD2 Q:SPNLEXIT
79 .. W !,?8,"| ",$E($$GET1^DIQ(4,SPNIEN,.01,"E"),1,40),?46,"| ",SPNFACN,?59,"| ",SPNFAC(SPNFACN),?72,"|"
80 .. W !,?8,$$REPEAT^XLFSTR("-",65) ; Last Line in table
81 .. Q
82 . Q
83 Q
84NEWPAT(SPNDFN) ; New patient to print
85 D HEAD Q:SPNLEXIT
86 N DFN
87 S DFN=SPNDFN D DEM^VADPT
88 W !!," Patient: ",$E(VADM(1),1,25),?38,"SSN: ",$P(VADM(2),U),?56,"SCI: ",$E($$GET1^DIQ(2,SPNDFN,57.4,"E"),1,23)
89 D KVAR^VADPT
90 S SPNCOU=SPNCOU+1
91 I '$D(^SPNL(154,SPNDFN,0)) Q
92 I $O(^SPNL(154,SPNDFN,"E",0))<1 Q
93 N SPNETI,SPNDFLG
94 S (SPNETI,SPNDFLG)=0 W !," Etiology: "
95 F S SPNETI=$O(^SPNL(154,SPNDFN,"E",SPNETI)) Q:SPNETI<1 D Q:SPNLEXIT
96 .N SPNETO
97 .S SPNETO=$P($G(^SPNL(154,SPNDFN,"E",SPNETI,0)),U) Q:SPNETO=""
98 .I $X>13 D HEAD Q:SPNLEXIT W !
99 .W ?12,$E($$GET^DDSVAL(154.03,SPNETO,.01,"","E"),1,30)
100 .I 'SPNDFLG W ?45,"Registration Date: ",$$FMTE^XLFDT($P($G(^SPNL(154,SPNDFN,0)),U,2),"2D") S SPNDFLG=1
101 .Q
102 Q
103PATIENT(SPNDFN,SPNLINE) ; Print Patient data
104 ; SPNLINE=Movement date(I)^pointer to PTF(I)^Length of Stay
105 ; ^Ward location(E)^D/C Date
106 ; SPNLINE=$P(VAIP(15,1),U,2)_U_VAIP(12)_U_SPNLOS_U_$P(VAIP(5),U,2)_U_SPNQDAT
107 Q:SPNLEXIT
108 W !,$$FMTE^XLFDT($P(SPNLINE,U,5),"2D"),?11,$P(SPNLINE,U,3)
109 W ?16,$E($P(SPNLINE,U,4),1,28)
110 Q:$P(SPNLINE,U,2)=""
111 N SPNODE,SPNNODE
112 S SPNNODE=$G(^DGPT($P(SPNLINE,U,2),70)) Q:SPNNODE=""
113 I $P(SPNNODE,U,12)?1N.N S SPNFAC=SPNFAC+1,SPNFAC($P(SPNNODE,U,12))=$G(SPNFAC($P(SPNNODE,U,12)))+1 ; Collect Receiving Facility
114 N SPNY
115 F SPNODE=10,16:1:24 D Q:SPNLEXIT
116 .S SPNY=$P(SPNNODE,U,SPNODE)
117 .I SPNY'>0 Q
118 .I $G(^ICD9(SPNY,0))="" Q
119 .I $X>50 D HEAD Q:SPNLEXIT W !
120 .W ?50,$E($$GET1^DIQ(80,SPNY,3,"E"),1,29)
121 .Q
122 I '$D(^SPNL(154,SPNDFN,0)) W !?2,"*** NOT IN THE REGISTRY ! ***"
123 Q
124HEAD ; Header Print
125 I SPNPAGE'=1 Q:$Y<(IOSL-4)
126 I $E(IOST,1)="C" D Q:SPNLEXIT
127 .I SPNPAGE=1 W @IOF Q
128 .I SPNPAGE'=1 D Q:SPNLEXIT
129 ..N DIR S DIR(0)="E" D ^DIR I 'Y S SPNLEXIT=1
130 ..K Y
131 ..Q
132 .Q
133 Q:SPNLEXIT
134 I SPNPAGE'=1 W @IOF
135 W !,$$FMTE^XLFDT($$NOW^XLFDT,1),?70,"Page: ",SPNPAGE
136 W !!,?27,"SCD/SCI Discharge Patients"
137 W !,?27,"From: ",$$FMTE^XLFDT(SPNDATE,"2D")," to: ",$$FMTE^XLFDT(SPNEDAT,"2D")
138 W !!,"Date D/C",?11,"LOS",?16,"D/C Location",?50,"Diagnosis Codes"
139 W !,$$REPEAT^XLFSTR("-",79)
140 S SPNPAGE=SPNPAGE+1
141 I $D(ZTQUEUED) S:$$STPCK^SPNPRTMT SPNLEXIT=1
142 Q
143HEAD2 ; Header Print
144 I SPNPAGE'=1 Q:$Y<(IOSL-4)
145 I $E(IOST,1)="C" D Q:SPNLEXIT
146 .I SPNPAGE=1 W @IOF Q
147 .I SPNPAGE'=1 D Q:SPNLEXIT
148 ..N DIR S DIR(0)="E" D ^DIR I 'Y S SPNLEXIT=1
149 ..K Y
150 ..Q
151 .Q
152 Q:SPNLEXIT
153 W @IOF
154 W !,$$FMTE^XLFDT($$NOW^XLFDT,1),?70,"Page: ",SPNPAGE
155 W !!,?27,"SCD/SCI Discharges Patients"
156 W !,?20,"Frequency Table of Discharge Destination"
157 W !!,?9,"Facility",?47,"Station #",?60,"Total"
158 W !,?8,$$REPEAT^XLFSTR("-",65) ; first Line in table
159 S SPNPAGE=SPNPAGE+1
160 I $D(ZTQUEUED) S:$$STPCK^SPNPRTMT SPNLEXIT=1
161 Q
Note: See TracBrowser for help on using the repository browser.