Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BWPRPCD

BWPRPCD.m

Go to the documentation of this file. 
  1. 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
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  DISPLAY CODE FOR PRINTING PROCEDURES.  ENTRY POINTS FOR PRINTING
  1.  ;;  INDIVIDUAL PROCEDURES AND ALL NEW PROCEDURES.
  1.  ;;  PATCHED AT LINE LABEL START+28.
  1.  ;
  1. TOP(DA) ;EP
  1.  ;---> PRINT PROCEDURE (NOT CALLED BY ANY OPTION).
  1.  ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 9002086.1.
  1.  ;
  1.  D SETVARS^BWUTL5
  1.  D DEVICE Q:BWPOP
  1.  D START(DA)
  1.  D ^%ZISC
  1.  W @IOF
  1.  Q
  1.  ;
  1.  ;
  1. STARTQ ;EP
  1.  ;---> ENTRY POINT FOR TASKMAN--CANNOT PASS PARAMETERS.
  1.  ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 9002086.1.
  1.  D START(DA)
  1.  Q
  1.  ;
  1.  ;
  1. START(DA) ;EP
  1.  N BWPRMT1,BWTITLE,BWY,N,X
  1.  D SETVARS^BWUTL5
  1.  S BWSL="I $Y+6>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP  D HEADER4^BWUTL7"
  1.  D TOPHEAD^BWUTL7,PCDVARS^BWUTL3(DA)
  1.  ;---> BWCRT=1 IF OUTPUT IS TO SCREEN (SET BY TOPHEAD^BWUTL7).
  1.  S BWTITLE1="* * *  WOMEN'S HEALTH: PROCEDURE PRINTOUT  * * *"
  1.  D CENTERT^BWUTL5(.BWTITLE1)
  1.  S BWPRMT1="   Press RETURN to continue or '^'to exit, or"
  1.  S BWY=^BWPCD(DA,0),BWDFN=$P(BWY,U,2)
  1.  ;
  1.  U IO
  1.  D HEADER4^BWUTL7 W:'BWCRT !
  1.  W !?5,"Date of Procedure: ",$$TXDT^BWUTL5($P(BWY,U,12))
  1.  W ?45,"PCC Date/Time: ",$$TXDT^BWUTL5($P(BWY,U,3))
  1.  W !?4,"Date First Entered: ",$$TXDT^BWUTL5($P(BWY,U,19))
  1.  W ?42,"First Entered By: " S X=$P(BWY,U,18) W $E($$PROV^BWUTL6,1,20)
  1.  W ! W:$P(BWY,U,15)]"" ?43,"Radiology Case#: ",$P(BWY,U,15)
  1.  W !?4,"Clinician/Provider: ",BWPROV
  1.  W !?2,"Ward/Clinic/Location: " S X=$P(BWY,U,11) W $$HOSPLC^BWUTL6
  1.  W !?2,"Health Care Facility: " S X=$P(BWY,U,10) W $$INSTTX^BWUTL6(X)
  1.  W !?6,"Clinical History: "
  1.  ;---> WRITE OUT CLINICAL HISTORY; IF TWO LINES, SPLIT BETWEEN WORDS.
  1.  D
  1.  .Q:'$D(^BWPCD(DA,3))
  1.  .N L,Y
  1.  .S Y=$P(^BWPCD(DA,3),U)
  1.  .S L=56 I Y[" " F  Q:$E(Y,L)=" "  S L=L-1
  1.  .;
  1.  .;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/25/97
  1.  .;---> Lengthened to display Radiology link message.   ;MWRZ 04/25/97
  1.  .;W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,99)            ;MWRZ 04/25/97
  1.  .W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,109)            ;MWRZ 04/25/97
  1.  .;===> ANMC MODS END, IHS/ANMC/MWRZ 04/25/97
  1.  ;
  1.  W !?4,"Complete by (Date): ",$$TXDT^BWUTL5($P(BWY,U,13))
  1.  W !?5,"Results/Diagnosis: ",BWRES
  1.  W !," Sec Results/diagnosis: " W $$DIAG^BWUTL4($P(BWY,U,6))
  1.  W ?57,"HPV: " W:$P(BWY,U,8) "YES"
  1.  W !?16,"Status: " S Y=BWY W $$STATUS^BWUTL4
  1.  ;
  1.  ;---> IF THIS PROCEDURE HAS COLPOSCOPY-TYPE RESULTS, DISPLAY COLP PAGE.
  1.  D:$$COLP^BWUTL4(DA)  Q:BWPOP
  1.  .I BWCRT D DIRZ^BWUTL3 Q:BWPOP  D HEADER4^BWUTL7
  1.  .S BWTITLE="-----  CLINICAL FINDINGS  -----"
  1.  .D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE
  1.  .;
  1.  .X BWSL Q:BWPOP  W !?2,"T-Zone Seen Entirely: "
  1.  .W $S($P(BWY,U,21):"YES",$P(BWY,U,21)=0:"NO",1:"")
  1.  .W ?54,"Multifocal: "
  1.  .W $S($P(BWY,U,21):"YES",$P(BWY,U,21)=0:"NO",1:"")
  1.  .;
  1.  .X BWSL Q:BWPOP  W !?2,"Lesion Outside Canal: "
  1.  .W $S($P(BWY,U,22):"YES",$P(BWY,U,22)=0:"NO",1:"")
  1.  .W ?45,"Number of Quadrants: " W $P(BWY,U,24)
  1.  .;
  1.  .X BWSL Q:BWPOP  W !?5,"Satisfactory Exam: "
  1.  .W $S($P(BWY,U,20):"YES",$P(BWY,U,20)=0:"NO",1:"")
  1.  .X BWSL Q:BWPOP  W !?12,"Impression: "
  1.  .W $$DIAG^BWUTL4($P(BWY,U,29))
  1.  .;
  1.  .X BWSL Q:BWPOP  S BWTITLE="-----  TISSUE PATHOLOGY  -----"
  1.  .D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE
  1.  .;
  1.  .X BWSL Q:BWPOP  W !?9,"ECC Dysplasia: "
  1.  .S X=$P(BWY,U,25) W $$ECCDYS^BWUTL6
  1.  .W ?57,"Margins Clear: "
  1.  .W $S($P(BWY,U,27):"YES",$P(BWY,U,27)=0:"NO",1:"") X BWSL Q:BWPOP
  1.  .X BWSL Q:BWPOP  W !?3,"Ectocervical Biopsy: "
  1.  .W $$DIAG^BWUTL4($P(BWY,U,26))
  1.  .W ?57,"Stage: "
  1.  .W $$STAGE^BWUTL4($P(BWY,U,31)) X BWSL Q:BWPOP
  1.  .X BWSL Q:BWPOP  W !?8,"STD Evaluation: "
  1.  .W $$DIAG^BWUTL4($P(BWY,U,28))
  1.  ;
  1.  I BWCRT D DIRZ^BWUTL3 Q:BWPOP  D HEADER4^BWUTL7
  1.  S BWTITLE="-----  TEXT OF LAB RESULT (received: "
  1.  S BWTITLE=BWTITLE_$$SLDT2^BWUTL5($P(BWY,U,32))_")  -----  "
  1.  D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE,!
  1.  S BWTITLE="-----  TEXT OF LAB RESULT (continued)  -----"
  1.  D CENTERT^BWUTL5(.BWTITLE) S BWSUBH=BWTITLE
  1.  S N=0
  1.  F  S N=$O(^BWPCD(DA,1,N)) Q:'N!(BWPOP)  D
  1.  .X BWSL Q:BWPOP
  1.  .W !,^BWPCD(DA,1,N,0)
  1.  S BWTITLE="-----  End of Procedure Printout  -----"
  1.  D CENTERT^BWUTL5(.BWTITLE) W !!,BWTITLE
  1.  K BWSUBH
  1.  D:BWCRT&('BWPOP) DIRZ^BWUTL3 W @IOF
  1.  Q
  1.  ;
  1. DEVICE ;EP
  1.  ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
  1.  S ZTRTN="STARTQ^BWPRPCD",ZTSAVE("DA")=""
  1.  D ZIS^BWUTL2(.BWPOP,1)
  1.  Q
  1.  ;
  1. JUSTPRT ;EP
  1.  ;---> CALLED BY OPTION: "BW  PRINT INDIVIDUAL PROCEDURES".
  1.  ;---> JUST PRINT AN INDIVIDUAL PROCEDURE.
  1.  N DA,Y
  1.  F  D  Q:Y<0
  1.  .D TITLE^BWUTL5("PRINT A PROCEDURE")
  1.  .D LKUPPCD^BWPROC(.Y)
  1.  .Q:Y<0
  1.  .;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/1/97
  1.  .;---> Use Listmanager for display/print.
  1.  .;---> NEXT TWO LINES CHANGED TO INCLUDE ^BWUTL5  ;IHS/ANMC/MWR 5/18/98
  1.  .I $$AGENCY^BWUTL5(DUZ(2))="i" D  Q
  1.  ..S DA=+Y D VIEWR^XBLM("START^BWPRPCD(DA)")
  1.  .D TOP(+Y)
  1.  .;===> ANMC MODS BEGIN, IHS/ANMC/MWRZ 04/1/97
  1.  D EXIT
  1.  Q
  1.  ;
  1. PRTNEW ;EP
  1.  ;---> CALLED BY OPTION: "BW PRINT ALL NEW PROCEDURES".
  1.  ;---> PRINT ALL PROCEDURES WITH A STATUS OF "NEW" (NEW UPLOADED
  1.  ;---> LAB RESULTS).
  1.  D TITLE^BWUTL5("PRINT ALL ""NEW"" PROCEDURES")
  1.  S ZTRTN="DEQUEUE^BWPRPCD"
  1.  D ZIS^BWUTL2(.BWPOP,1)
  1.  Q:BWPOP
  1.  ;
  1. DEQUEUE ;EP
  1.  ;---> FOR TASKMAN QUEUE OF PRINTOUT.
  1.  S N=0
  1.  F  S N=$O(^BWPCD("S","n",N)) Q:'N  D
  1.  .D START(N)
  1.  D ^%ZISC,EXIT
  1.  Q
  1.  ;
  1. EXIT ;EP
  1.  D KILLALL^BWUTL8
  1.  Q