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

WVPRPCD.m

Go to the documentation of this file. 
  1. 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
  1.  ;;  Original routine created by IHS/ANMC/MWR
  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.  ;
  1. TOP(DA) ;EP
  1.  ;---> PRINT PROCEDURE (NOT CALLED BY ANY OPTION).
  1.  ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE 790.1.
  1.  ;
  1.  D SETVARS^WVUTL5
  1.  D DEVICE Q:WVPOP
  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 790.1.
  1.  D START(DA),EXIT
  1.  Q
  1.  ;
  1.  ;
  1. START(DA) ;EP
  1.  N WVPRMT1,WVTITLE,WVY,N,X
  1.  D SETVARS^WVUTL5
  1.  S WVSL="I $Y+6>IOSL D:WVCRT DIRZ^WVUTL3 Q:WVPOP  D HEADER4^WVUTL7"
  1.  D TOPHEAD^WVUTL7,PCDVARS^WVUTL3(DA)
  1.  ;---> WVCRT=1 IF OUTPUT IS TO SCREEN (SET BY TOPHEAD^WVUTL7).
  1.  S WVTITLE1="* * *  WOMEN'S HEALTH: PROCEDURE PRINTOUT  * * *"
  1.  D CENTERT^WVUTL5(.WVTITLE1)
  1.  S WVPRMT1="   Press RETURN to continue or '^'to exit, or"
  1.  S WVY=^WV(790.1,DA,0),WVDFN=$P(WVY,U,2)
  1.  ;
  1.  U IO
  1.  D HEADER4^WVUTL7 W:'WVCRT !
  1.  W !?5,"Date of Procedure: ",$$TXDT^WVUTL5($P(WVY,U,12))
  1.  W !?4,"Date First Entered: ",$$TXDT^WVUTL5($P(WVY,U,19))
  1.  W ?42,"First Entered By: " S X=$P(WVY,U,18) W $E($$PROV^WVUTL6,1,20)
  1.  W ! W:$P(WVY,U,15)]"" ?43,"Radiology Case#: ",$P(WVY,U,15)
  1.  S X=$P($G(^WV(790.1,DA,2)),U,17) ;lab accession#
  1.  W:X]"" ?44,"Lab Accession#: ",X
  1.  W !?4,"Clinician/Provider: ",WVPROV
  1.  W !?2,"Ward/Clinic/Location: " S X=$P(WVY,U,11) W $$HOSPLC^WVUTL6
  1.  W !?2,"Health Care Facility: " S X=$P(WVY,U,10) W $$INSTTX^WVUTL6(X)
  1.  W !?14,"Comments: "
  1.  ;---> WRITE OUT CLINICAL HISTORY; IF TWO LINES, SPLIT BETWEEN WORDS.
  1.  D
  1.  .Q:'$D(^WV(790.1,DA,3))
  1.  .N L,Y
  1.  .S Y=$P(^WV(790.1,DA,3),U)
  1.  .I $L(Y)<57 W Y,! Q
  1.  .S L=56 I Y[" " F  Q:$E(Y,L)=" "  S L=L-1
  1.  .W $E(Y,1,L),! W:$L(Y)>56 ?24,$E(Y,L+1,109)
  1.  ;
  1.  W !?4,"Complete by (Date): ",$$TXDT^WVUTL5($P(WVY,U,13))
  1.  W !?5,"Results/Diagnosis: ",WVRES
  1.  W !," Sec Results/diagnosis: " W $$DIAG^WVUTL4($P(WVY,U,6))
  1.  W ?57,"HPV: " W:$P(WVY,U,8) "YES"
  1.  W !?16,"Status: " S Y=WVY W $$STATUS^WVUTL4
  1.  ;
  1.  ;---> IF THIS PROCEDURE HAS COLPOSCOPY-TYPE RESULTS, DISPLAY COLP PAGE.
  1.  D:$$COLP^WVUTL4(DA)  Q:WVPOP
  1.  .I WVCRT D DIRZ^WVUTL3 Q:WVPOP  D HEADER4^WVUTL7
  1.  .S WVTITLE="-----  CLINICAL FINDINGS  -----"
  1.  .D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
  1.  .;
  1.  .X WVSL Q:WVPOP  W !?2,"T-Zone Seen Entirely: "
  1.  .W $S($P(WVY,U,21):"YES",$P(WVY,U,21)=0:"NO",1:"")
  1.  .W ?54,"Multifocal: "
  1.  .W $S($P(WVY,U,21):"YES",$P(WVY,U,21)=0:"NO",1:"")
  1.  .;
  1.  .X WVSL Q:WVPOP  W !?2,"Lesion Outside Canal: "
  1.  .W $S($P(WVY,U,22):"YES",$P(WVY,U,22)=0:"NO",1:"")
  1.  .W ?45,"Number of Quadrants: " W $P(WVY,U,24)
  1.  .;
  1.  .X WVSL Q:WVPOP  W !?5,"Satisfactory Exam: "
  1.  .W $S($P(WVY,U,20):"YES",$P(WVY,U,20)=0:"NO",1:"")
  1.  .W ?46,"Quadrant Locations: ",$P($G(^WV(790.1,DA,2)),U,16)
  1.  .X WVSL Q:WVPOP  W !?12,"Impression: "
  1.  .W $$DIAG^WVUTL4($P(WVY,U,29))
  1.  .;
  1.  .X WVSL Q:WVPOP  S WVTITLE="-----  TISSUE PATHOLOGY  -----"
  1.  .D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
  1.  .;
  1.  .X WVSL Q:WVPOP  W !?9,"ECC Dysplasia: "
  1.  .S X=$P(WVY,U,25) W $$ECCDYS^WVUTL6
  1.  .W ?57,"Margins Clear: "
  1.  .W $S($P(WVY,U,27):"YES",$P(WVY,U,27)=0:"NO",1:"") X WVSL Q:WVPOP
  1.  .X WVSL Q:WVPOP  W !?3,"Ectocervical Biopsy: "
  1.  .W $$DIAG^WVUTL4($P(WVY,U,26))
  1.  .W ?57,"Stage: "
  1.  .W $$STAGE^WVUTL4($P(WVY,U,31)) X WVSL Q:WVPOP
  1.  .X WVSL Q:WVPOP  W !?8,"STD Evaluation: "
  1.  .W $$DIAG^WVUTL4($P(WVY,U,28))
  1.  ;
  1.  I WVCRT D DIRZ^WVUTL3 Q:WVPOP  D HEADER4^WVUTL7
  1.  S WVTITLE="-----  NOTES  -----  "
  1.  D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE,!
  1.  S WVTITLE="-----  NOTES (continued)  -----"
  1.  D CENTERT^WVUTL5(.WVTITLE) S WVSUBH=WVTITLE
  1.  S N=0
  1.  F  S N=$O(^WV(790.1,DA,1,N)) Q:'N!(WVPOP)  D
  1.  .X WVSL Q:WVPOP
  1.  .W !,^WV(790.1,DA,1,N,0)
  1.  S WVTITLE="-----  End of Procedure Printout  -----"
  1.  D CENTERT^WVUTL5(.WVTITLE) W !!,WVTITLE
  1.  K WVSUBH
  1.  I WVCRT&('$D(IO("S")))&('WVPOP) D DIRZ^WVUTL3 W @IOF
  1.  Q
  1.  ;
  1. DEVICE ;EP
  1.  ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
  1.  S ZTRTN="STARTQ^WVPRPCD",ZTSAVE("DA")=""
  1.  D ZIS^WVUTL2(.WVPOP,1)
  1.  Q
  1.  ;
  1. JUSTPRT ;EP
  1.  ;---> CALLED BY OPTION: "WV  PRINT INDIVIDUAL PROCEDURES".
  1.  ;---> JUST PRINT AN INDIVIDUAL PROCEDURE.
  1.  N DA,Y
  1.  F  D  Q:Y<0
  1.  .D TITLE^WVUTL5("PRINT A PROCEDURE")
  1.  .D LKUPPCD^WVPROC(.Y)
  1.  .Q:Y<0
  1.  .D TOP(+Y)
  1.  D EXIT
  1.  Q
  1.  ;
  1. PRTNEW ;EP
  1.  ;---> CALLED BY OPTION: "WV PRINT ALL NEW PROCEDURES".
  1.  ;---> PRINT ALL PROCEDURES WITH A STATUS OF "NEW" (NEW UPLOADED
  1.  ;---> LAB RESULTS).
  1.  D TITLE^WVUTL5("PRINT ALL ""NEW"" PROCEDURES")
  1.  S ZTRTN="DEQUEUE^WVPRPCD"
  1.  D ZIS^WVUTL2(.WVPOP,1)
  1.  I WVPOP D EXIT Q
  1.  ;
  1. DEQUEUE ;EP
  1.  ;---> FOR TASKMAN QUEUE OF PRINTOUT.
  1.  S N=0
  1.  F  S N=$O(^WV(790.1,"S","n",N)) Q:'N  D
  1.  .D START(N)
  1.  D ^%ZISC,EXIT
  1.  Q
  1.  ;
  1. EXIT ;EP
  1.  D KILLALL^WVUTL8
  1.  Q