source: WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVPRPCD.m@ 724

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1WVPRPCD ;HCIOFO/FT,JR-WV PRINT A PROCEDURE; ;8/5/99 15:58
2 ;;1.0;WOMEN'S HEALTH;**6,7**;Sep 30, 1998
3 ;; Original routine created by IHS/ANMC/MWR
4 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
5 ;; DISPLAY CODE FOR PRINTING PROCEDURES. ENTRY POINTS FOR PRINTING
6 ;; INDIVIDUAL PROCEDURES AND ALL NEW PROCEDURES.
7 ;
8TOP(DA) ;EP
9 ;---> PRINT PROCEDURE (NOT CALLED BY ANY OPTION).
10 ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
11 ;
12 D SETVARS^WVUTL5
13 D DEVICE Q:WVPOP
14 D START(DA)
15 D ^%ZISC
16 W @IOF
17 Q
18 ;
19 ;
20STARTQ ;EP
21 ;---> ENTRY POINT FOR TASKMAN--CANNOT PASS PARAMETERS.
22 ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
23 D START(DA)
24 Q
25 ;
26 ;
27START(DA) ;EP
28 N WVPRMT1,WVTITLE,WVY,N,X
29 D SETVARS^WVUTL5
30 S WVSL="I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER4^WVUTL7"
31 D TOPHEAD^WVUTL7,PCDVARS^WVUTL3(DA)
32 ;---> WVCRT=1 IF OUTPUT IS TO SCREEN (SET BY TOPHEAD^WVUTL7).
33 S WVTITLE1="* * * WOMEN'S HEALTH: PROCEDURE PRINTOUT * * *"
34 D CENTERT^WVUTL5(.WVTITLE1)
35 S WVPRMT1=" Press RETURN to continue or '^'to exit, or"
36 S WVY=^WV(790.1,DA,0),WVDFN=$P(WVY,U,2)
37 ;
38 U IO
39 D HEADER4^WVUTL7 W:'WVCRT !
40 W !?5,"Date of Procedure: ",$$TXDT^WVUTL5($P(WVY,U,12))
41 W !?4,"Date First Entered: ",$$TXDT^WVUTL5($P(WVY,U,19))
42 W ?42,"First Entered By: " S X=$P(WVY,U,18) W $E($$PROV^WVUTL6,1,20)
43 W ! W:$P(WVY,U,15)]"" ?43,"Radiology Case#: ",$P(WVY,U,15)
44 S X=$P($G(^WV(790.1,DA,2)),U,17) ;lab accession#
45 W:X]"" ?44,"Lab Accession#: ",X
46 W !?4,"Clinician/Provider: ",WVPROV
47 W !?2,"Ward/Clinic/Location: " S X=$P(WVY,U,11) W $$HOSPLC^WVUTL6
48 W !?2,"Health Care Facility: " S X=$P(WVY,U,10) W $$INSTTX^WVUTL6(X)
49 W !?14,"Comments: "
50 ;---> WRITE OUT CLINICAL HISTORY; IF TWO LINES, SPLIT BETWEEN WORDS.
51 D
52 .Q:'$D(^WV(790.1,DA,3))
53 .N L,Y
54 .S Y=$P(^WV(790.1,DA,3),U)
55 .I $L(Y)<57 W Y,! Q
56 .S L=56 I Y[" " F Q:$E(Y,L)=" " S L=L-1
57 .W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,109)
58 ;
59 W !?4,"Complete by (Date): ",$$TXDT^WVUTL5($P(WVY,U,13))
60 W !?5,"Results/Diagnosis: ",WVRES
61 W !," Sec Results/diagnosis: " W $$DIAG^WVUTL4($P(WVY,U,6))
62 W ?57,"HPV: " W:$P(WVY,U,8) "YES"
63 W !?16,"Status: " S Y=WVY W $$STATUS^WVUTL4
64 ;
65 ;---> IF THIS PROCEDURE HAS COLPOSCOPY-TYPE RESULTS, DISPLAY COLP PAGE.
66 D:$$COLP^WVUTL4(DA) Q:WVPOP
67 .I WVCRT D DIRZ^WVUTL3 Q:WVPOP D HEADER4^WVUTL7
68 .S WVTITLE="----- CLINICAL FINDINGS -----"
69 .D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
70 .;
71 .X WVSL Q:WVPOP W !?2,"T-Zone Seen Entirely: "
72 .W $S($P(WVY,U,21):"YES",$P(WVY,U,21)=0:"NO",1:"")
73 .W ?54,"Multifocal: "
74 .W $S($P(WVY,U,21):"YES",$P(WVY,U,21)=0:"NO",1:"")
75 .;
76 .X WVSL Q:WVPOP W !?2,"Lesion Outside Canal: "
77 .W $S($P(WVY,U,22):"YES",$P(WVY,U,22)=0:"NO",1:"")
78 .W ?45,"Number of Quadrants: " W $P(WVY,U,24)
79 .;
80 .X WVSL Q:WVPOP W !?5,"Satisfactory Exam: "
81 .W $S($P(WVY,U,20):"YES",$P(WVY,U,20)=0:"NO",1:"")
82 .W ?46,"Quadrant Locations: ",$P($G(^WV(790.1,DA,2)),U,16)
83 .X WVSL Q:WVPOP W !?12,"Impression: "
84 .W $$DIAG^WVUTL4($P(WVY,U,29))
85 .;
86 .X WVSL Q:WVPOP S WVTITLE="----- TISSUE PATHOLOGY -----"
87 .D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
88 .;
89 .X WVSL Q:WVPOP W !?9,"ECC Dysplasia: "
90 .S X=$P(WVY,U,25) W $$ECCDYS^WVUTL6
91 .W ?57,"Margins Clear: "
92 .W $S($P(WVY,U,27):"YES",$P(WVY,U,27)=0:"NO",1:"") X WVSL Q:WVPOP
93 .X WVSL Q:WVPOP W !?3,"Ectocervical Biopsy: "
94 .W $$DIAG^WVUTL4($P(WVY,U,26))
95 .W ?57,"Stage: "
96 .W $$STAGE^WVUTL4($P(WVY,U,31)) X WVSL Q:WVPOP
97 .X WVSL Q:WVPOP W !?8,"STD Evaluation: "
98 .W $$DIAG^WVUTL4($P(WVY,U,28))
99 ;
100 I WVCRT D DIRZ^WVUTL3 Q:WVPOP D HEADER4^WVUTL7
101 S WVTITLE="----- NOTES ----- "
102 D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE,!
103 S WVTITLE="----- NOTES (continued) -----"
104 D CENTERT^WVUTL5(.WVTITLE) S WVSUBH=WVTITLE
105 S N=0
106 F S N=$O(^WV(790.1,DA,1,N)) Q:'N!(WVPOP) D
107 .X WVSL Q:WVPOP
108 .W !,^WV(790.1,DA,1,N,0)
109 S WVTITLE="----- End of Procedure Printout -----"
110 D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
111 K WVSUBH
112 I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 W @IOF
113 Q
114 ;
115DEVICE ;EP
116 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
117 S ZTRTN="STARTQ^WVPRPCD",ZTSAVE("DA")=""
118 D ZIS^WVUTL2(.WVPOP,1)
119 Q
120 ;
121JUSTPRT ;EP
122 ;---> CALLED BY OPTION: "WV PRINT INDIVIDUAL PROCEDURES".
123 ;---> JUST PRINT AN INDIVIDUAL PROCEDURE.
124 N DA,Y
125 F D Q:Y<0
126 .D TITLE^WVUTL5("PRINT A PROCEDURE")
127 .D LKUPPCD^WVPROC(.Y)
128 .Q:Y<0
129 .D TOP(+Y)
130 D EXIT
131 Q
132 ;
133PRTNEW ;EP
134 ;---> CALLED BY OPTION: "WV PRINT ALL NEW PROCEDURES".
135 ;---> PRINT ALL PROCEDURES WITH A STATUS OF "NEW" (NEW UPLOADED
136 ;---> LAB RESULTS).
137 D TITLE^WVUTL5("PRINT ALL ""NEW"" PROCEDURES")
138 S ZTRTN="DEQUEUE^WVPRPCD"
139 D ZIS^WVUTL2(.WVPOP,1)
140 Q:WVPOP
141 ;
142DEQUEUE ;EP
143 ;---> FOR TASKMAN QUEUE OF PRINTOUT.
144 S N=0
145 F S N=$O(^WV(790.1,"S","n",N)) Q:'N D
146 .D START(N)
147 D ^%ZISC,EXIT
148 Q
149 ;
150EXIT ;EP
151 D KILLALL^WVUTL8
152 Q
Note: See TracBrowser for help on using the repository browser.