WVPRPCD ;HCIOFO/FT,JR - WV PRINT A PROCEDURE;08/28/2017 12:42
;;1.0;WOMEN'S HEALTH;**6,7,24**;Sep 30, 1998;Build 582
;; Original routine created by IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; DISPLAY CODE FOR PRINTING PROCEDURES. ENTRY POINTS FOR PRINTING
;; INDIVIDUAL PROCEDURES AND ALL NEW PROCEDURES.
;
TOP(DA) ;EP
;---> PRINT PROCEDURE (NOT CALLED BY ANY OPTION).
;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
;
D SETVARS^WVUTL5
D DEVICE Q:WVPOP
D START(DA)
D ^%ZISC
W @IOF
Q
;
;
STARTQ ;EP
;---> ENTRY POINT FOR TASKMAN--CANNOT PASS PARAMETERS.
;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
D START(DA),EXIT
Q
;
;
START(DA) ;EP
N WVPRMT1,WVTITLE,WVY,N,X
D SETVARS^WVUTL5
S WVSL="I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER4^WVUTL7"
D TOPHEAD^WVUTL7,PCDVARS^WVUTL3(DA)
;---> WVCRT=1 IF OUTPUT IS TO SCREEN (SET BY TOPHEAD^WVUTL7).
S WVTITLE1="* * * WOMEN'S HEALTH: PROCEDURE PRINTOUT * * *"
D CENTERT^WVUTL5(.WVTITLE1)
S WVPRMT1=" Press RETURN to continue or '^'to exit, or"
S WVY=^WV(790.1,DA,0),WVDFN=$P(WVY,U,2)
;
U IO
D HEADER4^WVUTL7 W:'WVCRT !
W !?5,"Date of Procedure: ",$$TXDT^WVUTL5($P(WVY,U,12))
W !?4,"Date First Entered: ",$$TXDT^WVUTL5($P(WVY,U,19))
W ?42,"First Entered By: " S X=$P(WVY,U,18) W $E($$PROV^WVUTL6,1,20)
W ! W:$P(WVY,U,15)]"" ?43,"Radiology Case#: ",$P(WVY,U,15)
S X=$P($G(^WV(790.1,DA,2)),U,17) ;lab accession#
W:X]"" ?44,"Lab Accession#: ",X
W !?4,"Clinician/Provider: ",WVPROV
W !?2,"Ward/Clinic/Location: " S X=$P(WVY,U,11) W $$HOSPLC^WVUTL6
W !?2,"Health Care Facility: " S X=$P(WVY,U,10) W $$INSTTX^WVUTL6(X)
W !?14,"Comments: "
;---> WRITE OUT CLINICAL HISTORY; IF TWO LINES, SPLIT BETWEEN WORDS.
D
.Q:'$D(^WV(790.1,DA,3))
.N L,Y
.S Y=$P(^WV(790.1,DA,3),U)
.I $L(Y)<57 W Y,! Q
.S L=56 I Y[" " F Q:$E(Y,L)=" " S L=L-1
.W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,109)
;
W !?4,"Complete by (Date): ",$$TXDT^WVUTL5($P(WVY,U,13))
W !?5,"Results/Diagnosis: ",WVRES
W !," Sec Results/diagnosis: " W $$DIAG^WVUTL4($P(WVY,U,6))
W ?57,"HPV: " W:$P(WVY,U,8) "YES"
W !?16,"Status: " S Y=WVY W $$STATUS^WVUTL4
;
;---> IF THIS PROCEDURE HAS COLPOSCOPY-TYPE RESULTS, DISPLAY COLP PAGE.
D:$$COLP^WVUTL4(DA) Q:WVPOP
.I WVCRT D DIRZ^WVUTL3 Q:WVPOP D HEADER4^WVUTL7
.S WVTITLE="----- CLINICAL FINDINGS -----"
.D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
.;
.X WVSL Q:WVPOP W !?2,"T-Zone Seen Entirely: "
.W $S($P(WVY,U,21):"YES",$P(WVY,U,21)=0:"NO",1:"")
.W ?54,"Multifocal: "
.W $S($P(WVY,U,21):"YES",$P(WVY,U,21)=0:"NO",1:"")
.;
.X WVSL Q:WVPOP W !?2,"Lesion Outside Canal: "
.W $S($P(WVY,U,22):"YES",$P(WVY,U,22)=0:"NO",1:"")
.W ?45,"Number of Quadrants: " W $P(WVY,U,24)
.;
.X WVSL Q:WVPOP W !?5,"Satisfactory Exam: "
.W $S($P(WVY,U,20):"YES",$P(WVY,U,20)=0:"NO",1:"")
.W ?46,"Quadrant Locations: ",$P($G(^WV(790.1,DA,2)),U,16)
.X WVSL Q:WVPOP W !?12,"Impression: "
.W $$DIAG^WVUTL4($P(WVY,U,29))
.;
.X WVSL Q:WVPOP S WVTITLE="----- TISSUE PATHOLOGY -----"
.D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
.;
.X WVSL Q:WVPOP W !?9,"ECC Dysplasia: "
.S X=$P(WVY,U,25) W $$ECCDYS^WVUTL6
.W ?57,"Margins Clear: "
.W $S($P(WVY,U,27):"YES",$P(WVY,U,27)=0:"NO",1:"") X WVSL Q:WVPOP
.X WVSL Q:WVPOP W !?3,"Ectocervical Biopsy: "
.W $$DIAG^WVUTL4($P(WVY,U,26))
.W ?57,"Stage: "
.W $$STAGE^WVUTL4($P(WVY,U,31)) X WVSL Q:WVPOP
.X WVSL Q:WVPOP W !?8,"STD Evaluation: "
.W $$DIAG^WVUTL4($P(WVY,U,28))
;
I WVCRT D DIRZ^WVUTL3 Q:WVPOP D HEADER4^WVUTL7
S WVTITLE="----- NOTES ----- "
D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE,!
S WVTITLE="----- NOTES (continued) -----"
D CENTERT^WVUTL5(.WVTITLE) S WVSUBH=WVTITLE
S N=0
F S N=$O(^WV(790.1,DA,1,N)) Q:'N!(WVPOP) D
.X WVSL Q:WVPOP
.W !,^WV(790.1,DA,1,N,0)
S WVTITLE="----- End of Procedure Printout -----"
D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
K WVSUBH
I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 W @IOF
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="STARTQ^WVPRPCD",ZTSAVE("DA")=""
D ZIS^WVUTL2(.WVPOP,1)
Q
;
JUSTPRT ;EP
;---> CALLED BY OPTION: "WV PRINT INDIVIDUAL PROCEDURES".
;---> JUST PRINT AN INDIVIDUAL PROCEDURE.
N DA,Y
F D Q:Y<0
.D TITLE^WVUTL5("PRINT A PROCEDURE")
.D LKUPPCD^WVPROC(.Y)
.Q:Y<0
.D TOP(+Y)
D EXIT
Q
;
PRTNEW ;EP
;---> CALLED BY OPTION: "WV PRINT ALL NEW PROCEDURES".
;---> PRINT ALL PROCEDURES WITH A STATUS OF "NEW" (NEW UPLOADED
;---> LAB RESULTS).
D TITLE^WVUTL5("PRINT ALL ""NEW"" PROCEDURES")
S ZTRTN="DEQUEUE^WVPRPCD"
D ZIS^WVUTL2(.WVPOP,1)
I WVPOP D EXIT Q
;
DEQUEUE ;EP
;---> FOR TASKMAN QUEUE OF PRINTOUT.
S N=0
F S N=$O(^WV(790.1,"S","n",N)) Q:'N D
.D START(N)
D ^%ZISC,EXIT
Q
;
EXIT ;EP
D KILLALL^WVUTL8
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVPRPCD 4922 printed Sep 23, 2025@20:23:48 Page 2
WVPRPCD ;HCIOFO/FT,JR - WV PRINT A PROCEDURE;08/28/2017 12:42
+1 ;;1.0;WOMEN'S HEALTH;**6,7,24**;Sep 30, 1998;Build 582
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; DISPLAY CODE FOR PRINTING PROCEDURES. ENTRY POINTS FOR PRINTING
+5 ;; INDIVIDUAL PROCEDURES AND ALL NEW PROCEDURES.
+6 ;
TOP(DA) ;EP
+1 ;---> PRINT PROCEDURE (NOT CALLED BY ANY OPTION).
+2 ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
+3 ;
+4 DO SETVARS^WVUTL5
+5 DO DEVICE
if WVPOP
QUIT
+6 DO START(DA)
+7 DO ^%ZISC
+8 WRITE @IOF
+9 QUIT
+10 ;
+11 ;
STARTQ ;EP
+1 ;---> ENTRY POINT FOR TASKMAN--CANNOT PASS PARAMETERS.
+2 ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
+3 DO START(DA)
DO EXIT
+4 QUIT
+5 ;
+6 ;
START(DA) ;EP
+1 NEW WVPRMT1,WVTITLE,WVY,N,X
+2 DO SETVARS^WVUTL5
+3 SET WVSL="I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP D HEADER4^WVUTL7"
+4 DO TOPHEAD^WVUTL7
DO PCDVARS^WVUTL3(DA)
+5 ;---> WVCRT=1 IF OUTPUT IS TO SCREEN (SET BY TOPHEAD^WVUTL7).
+6 SET WVTITLE1="* * * WOMEN'S HEALTH: PROCEDURE PRINTOUT * * *"
+7 DO CENTERT^WVUTL5(.WVTITLE1)
+8 SET WVPRMT1=" Press RETURN to continue or '^'to exit, or"
+9 SET WVY=^WV(790.1,DA,0)
SET WVDFN=$PIECE(WVY,U,2)
+10 ;
+11 USE IO
+12 DO HEADER4^WVUTL7
if 'WVCRT
WRITE !
+13 WRITE !?5,"Date of Procedure: ",$$TXDT^WVUTL5($PIECE(WVY,U,12))
+14 WRITE !?4,"Date First Entered: ",$$TXDT^WVUTL5($PIECE(WVY,U,19))
+15 WRITE ?42,"First Entered By: "
SET X=$PIECE(WVY,U,18)
WRITE $EXTRACT($$PROV^WVUTL6,1,20)
+16 WRITE !
if $PIECE(WVY,U,15)]""
WRITE ?43,"Radiology Case#: ",$PIECE(WVY,U,15)
+17 ;lab accession#
SET X=$PIECE($GET(^WV(790.1,DA,2)),U,17)
+18 if X]""
WRITE ?44,"Lab Accession#: ",X
+19 WRITE !?4,"Clinician/Provider: ",WVPROV
+20 WRITE !?2,"Ward/Clinic/Location: "
SET X=$PIECE(WVY,U,11)
WRITE $$HOSPLC^WVUTL6
+21 WRITE !?2,"Health Care Facility: "
SET X=$PIECE(WVY,U,10)
WRITE $$INSTTX^WVUTL6(X)
+22 WRITE !?14,"Comments: "
+23 ;---> WRITE OUT CLINICAL HISTORY; IF TWO LINES, SPLIT BETWEEN WORDS.
+24 Begin DoDot:1
+25 if '$DATA(^WV(790.1,DA,3))
QUIT
+26 NEW L,Y
+27 SET Y=$PIECE(^WV(790.1,DA,3),U)
+28 IF $LENGTH(Y)<57
WRITE Y,!
QUIT
+29 SET L=56
IF Y[" "
FOR
if $EXTRACT(Y,L)=" "
QUIT
SET L=L-1
+30 WRITE $EXTRACT(Y,1,L),!
if $LENGTH(Y)>56
WRITE ?24,$EXTRACT(Y,L+1,109)
End DoDot:1
+31 ;
+32 WRITE !?4,"Complete by (Date): ",$$TXDT^WVUTL5($PIECE(WVY,U,13))
+33 WRITE !?5,"Results/Diagnosis: ",WVRES
+34 WRITE !," Sec Results/diagnosis: "
WRITE $$DIAG^WVUTL4($PIECE(WVY,U,6))
+35 WRITE ?57,"HPV: "
if $PIECE(WVY,U,8)
WRITE "YES"
+36 WRITE !?16,"Status: "
SET Y=WVY
WRITE $$STATUS^WVUTL4
+37 ;
+38 ;---> IF THIS PROCEDURE HAS COLPOSCOPY-TYPE RESULTS, DISPLAY COLP PAGE.
+39 if $$COLP^WVUTL4(DA)
Begin DoDot:1
+40 IF WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
DO HEADER4^WVUTL7
+41 SET WVTITLE="----- CLINICAL FINDINGS -----"
+42 DO CENTERT^WVUTL5(.WVTITLE)
WRITE !!,WVTITLE
+43 ;
+44 XECUTE WVSL
if WVPOP
QUIT
WRITE !?2,"T-Zone Seen Entirely: "
+45 WRITE $SELECT($PIECE(WVY,U,21):"YES",$PIECE(WVY,U,21)=0:"NO",1:"")
+46 WRITE ?54,"Multifocal: "
+47 WRITE $SELECT($PIECE(WVY,U,21):"YES",$PIECE(WVY,U,21)=0:"NO",1:"")
+48 ;
+49 XECUTE WVSL
if WVPOP
QUIT
WRITE !?2,"Lesion Outside Canal: "
+50 WRITE $SELECT($PIECE(WVY,U,22):"YES",$PIECE(WVY,U,22)=0:"NO",1:"")
+51 WRITE ?45,"Number of Quadrants: "
WRITE $PIECE(WVY,U,24)
+52 ;
+53 XECUTE WVSL
if WVPOP
QUIT
WRITE !?5,"Satisfactory Exam: "
+54 WRITE $SELECT($PIECE(WVY,U,20):"YES",$PIECE(WVY,U,20)=0:"NO",1:"")
+55 WRITE ?46,"Quadrant Locations: ",$PIECE($GET(^WV(790.1,DA,2)),U,16)
+56 XECUTE WVSL
if WVPOP
QUIT
WRITE !?12,"Impression: "
+57 WRITE $$DIAG^WVUTL4($PIECE(WVY,U,29))
+58 ;
+59 XECUTE WVSL
if WVPOP
QUIT
SET WVTITLE="----- TISSUE PATHOLOGY -----"
+60 DO CENTERT^WVUTL5(.WVTITLE)
WRITE !!,WVTITLE
+61 ;
+62 XECUTE WVSL
if WVPOP
QUIT
WRITE !?9,"ECC Dysplasia: "
+63 SET X=$PIECE(WVY,U,25)
WRITE $$ECCDYS^WVUTL6
+64 WRITE ?57,"Margins Clear: "
+65 WRITE $SELECT($PIECE(WVY,U,27):"YES",$PIECE(WVY,U,27)=0:"NO",1:"")
XECUTE WVSL
if WVPOP
QUIT
+66 XECUTE WVSL
if WVPOP
QUIT
WRITE !?3,"Ectocervical Biopsy: "
+67 WRITE $$DIAG^WVUTL4($PIECE(WVY,U,26))
+68 WRITE ?57,"Stage: "
+69 WRITE $$STAGE^WVUTL4($PIECE(WVY,U,31))
XECUTE WVSL
if WVPOP
QUIT
+70 XECUTE WVSL
if WVPOP
QUIT
WRITE !?8,"STD Evaluation: "
+71 WRITE $$DIAG^WVUTL4($PIECE(WVY,U,28))
End DoDot:1
if WVPOP
QUIT
+72 ;
+73 IF WVCRT
DO DIRZ^WVUTL3
if WVPOP
QUIT
DO HEADER4^WVUTL7
+74 SET WVTITLE="----- NOTES ----- "
+75 DO CENTERT^WVUTL5(.WVTITLE)
WRITE !!,WVTITLE,!
+76 SET WVTITLE="----- NOTES (continued) -----"
+77 DO CENTERT^WVUTL5(.WVTITLE)
SET WVSUBH=WVTITLE
+78 SET N=0
+79 FOR
SET N=$ORDER(^WV(790.1,DA,1,N))
if 'N!(WVPOP)
QUIT
Begin DoDot:1
+80 XECUTE WVSL
if WVPOP
QUIT
+81 WRITE !,^WV(790.1,DA,1,N,0)
End DoDot:1
+82 SET WVTITLE="----- End of Procedure Printout -----"
+83 DO CENTERT^WVUTL5(.WVTITLE)
WRITE !!,WVTITLE
+84 KILL WVSUBH
+85 IF WVCRT&('$DATA(IO("S")))&('WVPOP)
DO DIRZ^WVUTL3
WRITE @IOF
+86 QUIT
+87 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="STARTQ^WVPRPCD"
SET ZTSAVE("DA")=""
+3 DO ZIS^WVUTL2(.WVPOP,1)
+4 QUIT
+5 ;
JUSTPRT ;EP
+1 ;---> CALLED BY OPTION: "WV PRINT INDIVIDUAL PROCEDURES".
+2 ;---> JUST PRINT AN INDIVIDUAL PROCEDURE.
+3 NEW DA,Y
+4 FOR
Begin DoDot:1
+5 DO TITLE^WVUTL5("PRINT A PROCEDURE")
+6 DO LKUPPCD^WVPROC(.Y)
+7 if Y<0
QUIT
+8 DO TOP(+Y)
End DoDot:1
if Y<0
QUIT
+9 DO EXIT
+10 QUIT
+11 ;
PRTNEW ;EP
+1 ;---> CALLED BY OPTION: "WV PRINT ALL NEW PROCEDURES".
+2 ;---> PRINT ALL PROCEDURES WITH A STATUS OF "NEW" (NEW UPLOADED
+3 ;---> LAB RESULTS).
+4 DO TITLE^WVUTL5("PRINT ALL ""NEW"" PROCEDURES")
+5 SET ZTRTN="DEQUEUE^WVPRPCD"
+6 DO ZIS^WVUTL2(.WVPOP,1)
+7 IF WVPOP
DO EXIT
QUIT
+8 ;
DEQUEUE ;EP
+1 ;---> FOR TASKMAN QUEUE OF PRINTOUT.
+2 SET N=0
+3 FOR
SET N=$ORDER(^WV(790.1,"S","n",N))
if 'N
QUIT
Begin DoDot:1
+4 DO START(N)
End DoDot:1
+5 DO ^%ZISC
DO EXIT
+6 QUIT
+7 ;
EXIT ;EP
+1 DO KILLALL^WVUTL8
+2 QUIT
