BWPRPCD ;IHS/ANMC/MWR - BW PRINT A PROCEDURE;15-Feb-2003 22:08;PLS
;;2.0;WOMEN'S HEALTH;**3,8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; DISPLAY CODE FOR PRINTING PROCEDURES. ENTRY POINTS FOR PRINTING
;; INDIVIDUAL PROCEDURES AND ALL NEW PROCEDURES.
;; PATCHED AT LINE LABEL START+28.
;
TOP(DA) ;EP
;---> PRINT PROCEDURE (NOT CALLED BY ANY OPTION).
;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 9002086.1.
;
D SETVARS^BWUTL5
D DEVICE Q:BWPOP
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 9002086.1.
D START(DA)
Q
;
;
START(DA) ;EP
N BWPRMT1,BWTITLE,BWY,N,X
D SETVARS^BWUTL5
S BWSL="I $Y+6>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP D HEADER4^BWUTL7"
D TOPHEAD^BWUTL7,PCDVARS^BWUTL3(DA)
;---> BWCRT=1 IF OUTPUT IS TO SCREEN (SET BY TOPHEAD^BWUTL7).
S BWTITLE1="* * * WOMEN'S HEALTH: PROCEDURE PRINTOUT * * *"
D CENTERT^BWUTL5(.BWTITLE1)
S BWPRMT1=" Press RETURN to continue or '^'to exit, or"
S BWY=^BWPCD(DA,0),BWDFN=$P(BWY,U,2)
;
U IO
D HEADER4^BWUTL7 W:'BWCRT !
W !?5,"Date of Procedure: ",$$TXDT^BWUTL5($P(BWY,U,12))
W ?45,"PCC Date/Time: ",$$TXDT^BWUTL5($P(BWY,U,3))
W !?4,"Date First Entered: ",$$TXDT^BWUTL5($P(BWY,U,19))
W ?42,"First Entered By: " S X=$P(BWY,U,18) W $E($$PROV^BWUTL6,1,20)
W ! W:$P(BWY,U,15)]"" ?43,"Radiology Case#: ",$P(BWY,U,15)
W !?4,"Clinician/Provider: ",BWPROV
W !?2,"Ward/Clinic/Location: " S X=$P(BWY,U,11) W $$HOSPLC^BWUTL6
W !?2,"Health Care Facility: " S X=$P(BWY,U,10) W $$INSTTX^BWUTL6(X)
W !?6,"Clinical History: "
;---> WRITE OUT CLINICAL HISTORY; IF TWO LINES, SPLIT BETWEEN WORDS.
D
.Q:'$D(^BWPCD(DA,3))
.N L,Y
.S Y=$P(^BWPCD(DA,3),U)
.S L=56 I Y[" " F Q:$E(Y,L)=" " S L=L-1
.;
.;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/25/97
.;---> Lengthened to display Radiology link message. ;MWRZ 04/25/97
.;W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,99) ;MWRZ 04/25/97
.W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,109) ;MWRZ 04/25/97
.;===> ANMC MODS END, IHS/ANMC/MWRZ 04/25/97
;
W !?4,"Complete by (Date): ",$$TXDT^BWUTL5($P(BWY,U,13))
W !?5,"Results/Diagnosis: ",BWRES
W !," Sec Results/diagnosis: " W $$DIAG^BWUTL4($P(BWY,U,6))
W ?57,"HPV: " W:$P(BWY,U,8) "YES"
W !?16,"Status: " S Y=BWY W $$STATUS^BWUTL4
;
;---> IF THIS PROCEDURE HAS COLPOSCOPY-TYPE RESULTS, DISPLAY COLP PAGE.
D:$$COLP^BWUTL4(DA) Q:BWPOP
.I BWCRT D DIRZ^BWUTL3 Q:BWPOP D HEADER4^BWUTL7
.S BWTITLE="----- CLINICAL FINDINGS -----"
.D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE
.;
.X BWSL Q:BWPOP W !?2,"T-Zone Seen Entirely: "
.W $S($P(BWY,U,21):"YES",$P(BWY,U,21)=0:"NO",1:"")
.W ?54,"Multifocal: "
.W $S($P(BWY,U,21):"YES",$P(BWY,U,21)=0:"NO",1:"")
.;
.X BWSL Q:BWPOP W !?2,"Lesion Outside Canal: "
.W $S($P(BWY,U,22):"YES",$P(BWY,U,22)=0:"NO",1:"")
.W ?45,"Number of Quadrants: " W $P(BWY,U,24)
.;
.X BWSL Q:BWPOP W !?5,"Satisfactory Exam: "
.W $S($P(BWY,U,20):"YES",$P(BWY,U,20)=0:"NO",1:"")
.X BWSL Q:BWPOP W !?12,"Impression: "
.W $$DIAG^BWUTL4($P(BWY,U,29))
.;
.X BWSL Q:BWPOP S BWTITLE="----- TISSUE PATHOLOGY -----"
.D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE
.;
.X BWSL Q:BWPOP W !?9,"ECC Dysplasia: "
.S X=$P(BWY,U,25) W $$ECCDYS^BWUTL6
.W ?57,"Margins Clear: "
.W $S($P(BWY,U,27):"YES",$P(BWY,U,27)=0:"NO",1:"") X BWSL Q:BWPOP
.X BWSL Q:BWPOP W !?3,"Ectocervical Biopsy: "
.W $$DIAG^BWUTL4($P(BWY,U,26))
.W ?57,"Stage: "
.W $$STAGE^BWUTL4($P(BWY,U,31)) X BWSL Q:BWPOP
.X BWSL Q:BWPOP W !?8,"STD Evaluation: "
.W $$DIAG^BWUTL4($P(BWY,U,28))
;
I BWCRT D DIRZ^BWUTL3 Q:BWPOP D HEADER4^BWUTL7
S BWTITLE="----- TEXT OF LAB RESULT (received: "
S BWTITLE=BWTITLE_$$SLDT2^BWUTL5($P(BWY,U,32))_") ----- "
D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE,!
S BWTITLE="----- TEXT OF LAB RESULT (continued) -----"
D CENTERT^BWUTL5(.BWTITLE) S BWSUBH=BWTITLE
S N=0
F S N=$O(^BWPCD(DA,1,N)) Q:'N!(BWPOP) D
.X BWSL Q:BWPOP
.W !,^BWPCD(DA,1,N,0)
S BWTITLE="----- End of Procedure Printout -----"
D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE
K BWSUBH
D:BWCRT&('BWPOP) DIRZ^BWUTL3 W @IOF
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="STARTQ^BWPRPCD",ZTSAVE("DA")=""
D ZIS^BWUTL2(.BWPOP,1)
Q
;
JUSTPRT ;EP
;---> CALLED BY OPTION: "BW PRINT INDIVIDUAL PROCEDURES".
;---> JUST PRINT AN INDIVIDUAL PROCEDURE.
N DA,Y
F D Q:Y<0
.D TITLE^BWUTL5("PRINT A PROCEDURE")
.D LKUPPCD^BWPROC(.Y)
.Q:Y<0
.;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/1/97
.;---> Use Listmanager for display/print.
.;---> NEXT TWO LINES CHANGED TO INCLUDE ^BWUTL5 ;IHS/ANMC/MWR 5/18/98
.I $$AGENCY^BWUTL5(DUZ(2))="i" D Q
..S DA=+Y D VIEWR^XBLM("START^BWPRPCD(DA)")
.D TOP(+Y)
.;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/1/97
D EXIT
Q
;
PRTNEW ;EP
;---> CALLED BY OPTION: "BW PRINT ALL NEW PROCEDURES".
;---> PRINT ALL PROCEDURES WITH A STATUS OF "NEW" (NEW UPLOADED
;---> LAB RESULTS).
D TITLE^BWUTL5("PRINT ALL ""NEW"" PROCEDURES")
S ZTRTN="DEQUEUE^BWPRPCD"
D ZIS^BWUTL2(.BWPOP,1)
Q:BWPOP
;
DEQUEUE ;EP
;---> FOR TASKMAN QUEUE OF PRINTOUT.
S N=0
F S N=$O(^BWPCD("S","n",N)) Q:'N D
.D START(N)
D ^%ZISC,EXIT
Q
;
EXIT ;EP
D KILLALL^BWUTL8
Q
BWPRPCD ;IHS/ANMC/MWR - BW PRINT A PROCEDURE;15-Feb-2003 22:08;PLS
+1 ;;2.0;WOMEN'S HEALTH;**3,8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; DISPLAY CODE FOR PRINTING PROCEDURES. ENTRY POINTS FOR PRINTING
+4 ;; INDIVIDUAL PROCEDURES AND ALL NEW PROCEDURES.
+5 ;; PATCHED AT LINE LABEL START+28.
+6 ;
TOP(DA) ;EP
+1 ;---> PRINT PROCEDURE (NOT CALLED BY ANY OPTION).
+2 ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 9002086.1.
+3 ;
+4 DO SETVARS^BWUTL5
+5 DO DEVICE
IF BWPOP
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 9002086.1.
+3 DO START(DA)
+4 QUIT
+5 ;
+6 ;
START(DA) ;EP
+1 NEW BWPRMT1,BWTITLE,BWY,N,X
+2 DO SETVARS^BWUTL5
+3 SET BWSL="I $Y+6>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP D HEADER4^BWUTL7"
+4 DO TOPHEAD^BWUTL7
DO PCDVARS^BWUTL3(DA)
+5 ;---> BWCRT=1 IF OUTPUT IS TO SCREEN (SET BY TOPHEAD^BWUTL7).
+6 SET BWTITLE1="* * * WOMEN'S HEALTH: PROCEDURE PRINTOUT * * *"
+7 DO CENTERT^BWUTL5(.BWTITLE1)
+8 SET BWPRMT1=" Press RETURN to continue or '^'to exit, or"
+9 SET BWY=^BWPCD(DA,0)
SET BWDFN=$PIECE(BWY,U,2)
+10 ;
+11 USE IO
+12 DO HEADER4^BWUTL7
IF 'BWCRT
WRITE !
+13 WRITE !?5,"Date of Procedure: ",$$TXDT^BWUTL5($PIECE(BWY,U,12))
+14 WRITE ?45,"PCC Date/Time: ",$$TXDT^BWUTL5($PIECE(BWY,U,3))
+15 WRITE !?4,"Date First Entered: ",$$TXDT^BWUTL5($PIECE(BWY,U,19))
+16 WRITE ?42,"First Entered By: "
SET X=$PIECE(BWY,U,18)
WRITE $EXTRACT($$PROV^BWUTL6,1,20)
+17 WRITE !
IF $PIECE(BWY,U,15)]""
WRITE ?43,"Radiology Case#: ",$PIECE(BWY,U,15)
+18 WRITE !?4,"Clinician/Provider: ",BWPROV
+19 WRITE !?2,"Ward/Clinic/Location: "
SET X=$PIECE(BWY,U,11)
WRITE $$HOSPLC^BWUTL6
+20 WRITE !?2,"Health Care Facility: "
SET X=$PIECE(BWY,U,10)
WRITE $$INSTTX^BWUTL6(X)
+21 WRITE !?6,"Clinical History: "
+22 ;---> WRITE OUT CLINICAL HISTORY; IF TWO LINES, SPLIT BETWEEN WORDS.
+23 Begin DoDot:1
+24 IF '$DATA(^BWPCD(DA,3))
QUIT
+25 NEW L,Y
+26 SET Y=$PIECE(^BWPCD(DA,3),U)
+27 SET L=56
IF Y[" "
FOR
IF $EXTRACT(Y,L)=" "
QUIT
SET L=L-1
+28 ;
+29 ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/25/97
+30 ;---> Lengthened to display Radiology link message. ;MWRZ 04/25/97
+31 ;W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,99) ;MWRZ 04/25/97
+32 ;MWRZ 04/25/97
WRITE $EXTRACT(Y,1,L),!
IF $LENGTH(Y)>56
WRITE ?24,$EXTRACT(Y,L+1,109)
+33 ;===> ANMC MODS END, IHS/ANMC/MWRZ 04/25/97
End DoDot:1
+34 ;
+35 WRITE !?4,"Complete by (Date): ",$$TXDT^BWUTL5($PIECE(BWY,U,13))
+36 WRITE !?5,"Results/Diagnosis: ",BWRES
+37 WRITE !," Sec Results/diagnosis: "
WRITE $$DIAG^BWUTL4($PIECE(BWY,U,6))
+38 WRITE ?57,"HPV: "
IF $PIECE(BWY,U,8)
WRITE "YES"
+39 WRITE !?16,"Status: "
SET Y=BWY
WRITE $$STATUS^BWUTL4
+40 ;
+41 ;---> IF THIS PROCEDURE HAS COLPOSCOPY-TYPE RESULTS, DISPLAY COLP PAGE.
+42 IF $$COLP^BWUTL4(DA)
Begin DoDot:1
+43 IF BWCRT
DO DIRZ^BWUTL3
IF BWPOP
QUIT
DO HEADER4^BWUTL7
+44 SET BWTITLE="----- CLINICAL FINDINGS -----"
+45 DO CENTERT^BWUTL5(.BWTITLE)
WRITE !!,BWTITLE
+46 ;
+47 XECUTE BWSL
IF BWPOP
QUIT
WRITE !?2,"T-Zone Seen Entirely: "
+48 WRITE $SELECT($PIECE(BWY,U,21):"YES",$PIECE(BWY,U,21)=0:"NO",1:"")
+49 WRITE ?54,"Multifocal: "
+50 WRITE $SELECT($PIECE(BWY,U,21):"YES",$PIECE(BWY,U,21)=0:"NO",1:"")
+51 ;
+52 XECUTE BWSL
IF BWPOP
QUIT
WRITE !?2,"Lesion Outside Canal: "
+53 WRITE $SELECT($PIECE(BWY,U,22):"YES",$PIECE(BWY,U,22)=0:"NO",1:"")
+54 WRITE ?45,"Number of Quadrants: "
WRITE $PIECE(BWY,U,24)
+55 ;
+56 XECUTE BWSL
IF BWPOP
QUIT
WRITE !?5,"Satisfactory Exam: "
+57 WRITE $SELECT($PIECE(BWY,U,20):"YES",$PIECE(BWY,U,20)=0:"NO",1:"")
+58 XECUTE BWSL
IF BWPOP
QUIT
WRITE !?12,"Impression: "
+59 WRITE $$DIAG^BWUTL4($PIECE(BWY,U,29))
+60 ;
+61 XECUTE BWSL
IF BWPOP
QUIT
SET BWTITLE="----- TISSUE PATHOLOGY -----"
+62 DO CENTERT^BWUTL5(.BWTITLE)
WRITE !!,BWTITLE
+63 ;
+64 XECUTE BWSL
IF BWPOP
QUIT
WRITE !?9,"ECC Dysplasia: "
+65 SET X=$PIECE(BWY,U,25)
WRITE $$ECCDYS^BWUTL6
+66 WRITE ?57,"Margins Clear: "
+67 WRITE $SELECT($PIECE(BWY,U,27):"YES",$PIECE(BWY,U,27)=0:"NO",1:"")
XECUTE BWSL
IF BWPOP
QUIT
+68 XECUTE BWSL
IF BWPOP
QUIT
WRITE !?3,"Ectocervical Biopsy: "
+69 WRITE $$DIAG^BWUTL4($PIECE(BWY,U,26))
+70 WRITE ?57,"Stage: "
+71 WRITE $$STAGE^BWUTL4($PIECE(BWY,U,31))
XECUTE BWSL
IF BWPOP
QUIT
+72 XECUTE BWSL
IF BWPOP
QUIT
WRITE !?8,"STD Evaluation: "
+73 WRITE $$DIAG^BWUTL4($PIECE(BWY,U,28))
End DoDot:1
IF BWPOP
QUIT
+74 ;
+75 IF BWCRT
DO DIRZ^BWUTL3
IF BWPOP
QUIT
DO HEADER4^BWUTL7
+76 SET BWTITLE="----- TEXT OF LAB RESULT (received: "
+77 SET BWTITLE=BWTITLE_$$SLDT2^BWUTL5($PIECE(BWY,U,32))_") ----- "
+78 DO CENTERT^BWUTL5(.BWTITLE)
WRITE !!,BWTITLE,!
+79 SET BWTITLE="----- TEXT OF LAB RESULT (continued) -----"
+80 DO CENTERT^BWUTL5(.BWTITLE)
SET BWSUBH=BWTITLE
+81 SET N=0
+82 FOR
SET N=$ORDER(^BWPCD(DA,1,N))
IF 'N!(BWPOP)
QUIT
Begin DoDot:1
+83 XECUTE BWSL
IF BWPOP
QUIT
+84 WRITE !,^BWPCD(DA,1,N,0)
End DoDot:1
+85 SET BWTITLE="----- End of Procedure Printout -----"
+86 DO CENTERT^BWUTL5(.BWTITLE)
WRITE !!,BWTITLE
+87 KILL BWSUBH
+88 IF BWCRT&('BWPOP)
DO DIRZ^BWUTL3
WRITE @IOF
+89 QUIT
+90 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="STARTQ^BWPRPCD"
SET ZTSAVE("DA")=""
+3 DO ZIS^BWUTL2(.BWPOP,1)
+4 QUIT
+5 ;
JUSTPRT ;EP
+1 ;---> CALLED BY OPTION: "BW PRINT INDIVIDUAL PROCEDURES".
+2 ;---> JUST PRINT AN INDIVIDUAL PROCEDURE.
+3 NEW DA,Y
+4 FOR
Begin DoDot:1
+5 DO TITLE^BWUTL5("PRINT A PROCEDURE")
+6 DO LKUPPCD^BWPROC(.Y)
+7 IF Y<0
QUIT
+8 ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/1/97
+9 ;---> Use Listmanager for display/print.
+10 ;---> NEXT TWO LINES CHANGED TO INCLUDE ^BWUTL5 ;IHS/ANMC/MWR 5/18/98
+11 IF $$AGENCY^BWUTL5(DUZ(2))="i"
Begin DoDot:2
+12 SET DA=+Y
DO VIEWR^XBLM("START^BWPRPCD(DA)")
End DoDot:2
QUIT
+13 DO TOP(+Y)
+14 ;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/1/97
End DoDot:1
IF Y<0
QUIT
+15 DO EXIT
+16 QUIT
+17 ;
PRTNEW ;EP
+1 ;---> CALLED BY OPTION: "BW PRINT ALL NEW PROCEDURES".
+2 ;---> PRINT ALL PROCEDURES WITH A STATUS OF "NEW" (NEW UPLOADED
+3 ;---> LAB RESULTS).
+4 DO TITLE^BWUTL5("PRINT ALL ""NEW"" PROCEDURES")
+5 SET ZTRTN="DEQUEUE^BWPRPCD"
+6 DO ZIS^BWUTL2(.BWPOP,1)
+7 IF BWPOP
QUIT
+8 ;
DEQUEUE ;EP
+1 ;---> FOR TASKMAN QUEUE OF PRINTOUT.
+2 SET N=0
+3 FOR
SET N=$ORDER(^BWPCD("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^BWUTL8
+2 QUIT
