source: FOIAVistA/trunk/r/WOMENS_HEALTH-WV/WVUTL2.m@ 1404

WVUTL2 ;HCIOFO/FT,JR IHS/ANMC/MWR - UTIL: ZIS, XREF, PROSCREEN; ;9/1/98  11:37
 ;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
 ;;  UTILITY: ZIS, MUMPS XREFS ON NORMAL/ABNORMAL AND ON STATUS.
 ;;  PROCSCRN-SCREEN ON RESULT/DIAGNOSIS BASED ON PROCEDURE.
 ;
 ;
ZIS(WVPOP,WVQUE,WVDEF,WVPRMPT,WVMES) ;EP
 ;---> CALL TO ^%ZIS
 ;---> PARAMETERS:
D ;     1 - WVPOP         (RETURNED) WVPOP=1 IF POP=1 (FAIL OR QUIT).
 ;     2 - WVQUE=1       (OPTIONAL) SET=1 IF JOB SHOULD WV QUEUEABLE.
 ;     3 - WVDEF=DEFAULT (OPTIONAL) IF EXISTS, EQUALS DEFAULT DEVICE.
 ;     4 - WVPRMPT       (OPTIONAL) IF EXISTS, EQUALS PROMPT.
 ;     5 - WVMES         (OPTIONAL) A MESSAGE TO DISPLAY IF QUEUED.
 ;
 ;---> EXAMPLE: D ZIS^WVUTL2(.WVPOP,1,"HOME")
 ;
ZIS1 ;EP FOR LOOP BACK FROM FAILED WVQUE.
 S WVPOP=0
 ;
 ;---> WVPRMPT=WVPRMPT.
 S %ZIS("A")=$S($D(WVPRMPT):WVPRMPT,1:"   Select DEVICE: ")
 ;
 ;---> WVDEF=DEFAULT PRINTER.
 ;---> IF NO WVDEF, SET WVDEF="P" FOR CLOSEST PRINTER.
 D
 .I '$D(WVDEF) S %ZIS="P" Q
 .S %ZIS("B")=WVDEF,%ZIS=""
 ;
 ;---> IF WVQUE=1,JOB MAY BE QUEUED.
 I $G(WVQUE)]"" I WVQUE S %ZIS=%ZIS_"Q"
 ;
 W ! D ^%ZIS S:POP WVPOP=1
 ;---> QUIT IF WVPOP (DUOUT OR DTOUT) OR IF NOT WVQUED.
 G:WVPOP!('$D(IO("Q"))) ZISEXIT
 ;
 I IO=IO(0) W !?5,"Cannot queue to screen or slave printer!",! G ZIS1
 ;
 ;---> NEXT LINE: LINE LABEL "ZISQ" ADDED FOR ENTRY WHERE DEVICE
 ;---> INFO HAS ALREADY BEEN ASKED AND USER WVQUED OUTPUT.
ZISQ ;EP
 ;---> NEXT LINES: JOB WAS QUEUED, THEREFORE SET WVPOP=1 SO THAT THE
 ;---> CALLING ROUTINE WILL QUIT (AND LET TASKMAN FINISH THIS JOB).
 S WVPOP=1
 I '$D(ZTRTN) D  G ZISEXIT
 .W !?5,*7,"NO ROUTINE NAMED FOR QUEUEING -- CONTACT PROGRAMMER."
 I '$D(ZTDESC) S ZTDESC=ZTRTN
 S WVMES=$S($D(WVMES):WVMES,1:"W !?5,""Request Queued."",!")
 ;
 S ZTIO=$S($D(ION):ION,1:"")
 I ZTIO]"" D
 .I $D(IO("DOC")) S ZTIO=ZTIO_";"_IOST_";"_IO("DOC") Q
 .S ZTIO=ZTIO_";"_IOST_";"_IOM_";"_IOSL
 S ZTDTH=$H
 D ^%ZTLOAD,^%ZISC
 ;---> SET WVPOP=1 TO TELL CALLING ROUTINE TO QUIT (LET TASKMAN FINISH).
 S WVPOP=1
 X:$D(ZTSK) WVMES H 2
 ;
ZISEXIT ;EP
 K WVMES,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
 Q
 ;
 ;
XREFP05 ;EP
 ;---> CALLED BY MUMPS "ABNML" XREF ON FIELD .05 IN FILE 790.1.
 ;---> REINDEX RESULTS FIELD .05 IN WV PROCEDURE FILE, BY DATE
 ;---> (PIECE 12), WHEN RESULT/DIAGNOSIS IS "ABNORMAL" (AS STORED IN
 ;---> PIECE 21 OF THE POINTED TO WV RESULTS/DIAGNOSIS ENTRY).
 ;---> X=IEN WV RESULT/DIAGNOSIS, DA=ENTRY IN WV PROCEDURE FILE.
 Q:'$P(^WV(790.1,DA,0),U,12)
 I $P(^WV(790.31,X,0),U,21) S ^WV(790.1,"ABNML",$P(^WV(790.1,DA,0),U,12),DA)="" Q
 K ^WV(790.1,"ABNML",$P(^WV(790.1,DA,0),U,12),DA)
 Q
 ;
XREFP12 ;EP
 ;---> CALLED BY MUMPS "ABNML1" XREF ON FIELD .12 IN FILE 790.1.
 ;---> LOGIC TO REINDEX RESULTS FIELD .05 IN WV PROCEDURE FILE WHEN
 ;---> DATE OF PROCEDURE .12 FIELD IS CHANGED.  X=NEWDATE, DA=ENTRY.
 ;---> SEE XREFP05 ABOVE.
 I '$P(^WV(790.1,DA,0),U,5) S ^WV(790.1,"ABNML",X,DA)="" Q
 I $P(^WV(790.31,$P(^WV(790.1,DA,0),U,5),0),U,21) S ^WV(790.1,"ABNML",X,DA)="" Q
 K ^WV(790.1,"ABNML",X,DA)
 Q
 ;
REXREFN ;EP
 ;---> CALLED BY MUMPS XREF ON FIELD .02 IN FILE 790.4.
 ;---> LOGIC TO REINDEX STATUS FIELD .14 IN WV NOTIFICATION FILE
 ;---> WHEN DATE NOTIFICATION OPENED .02 FIELD IS CHANGED.
 ;---> X=NEWDATE, DA=ENTRY.
 ;---> NOTE: IF STATUS IS NULL XREF FOR "AOPEN" GETS SET HERE.
 I $P(^WV(790.4,DA,0),U,2) K ^WV(790.4,"AOPEN",$P(^(0),U,2),DA)
 I "o"[$P(^WV(790.4,DA,0),U,14) S ^WV(790.4,"AOPEN",X,DA)=""
 Q
 ;
 ;
PROCSCRN ;EP
 ;---> SCREEN WHEN SELECTING RESULTS/DIAGNOSIS FOR PROCEDURES.
 ;---> CALLED BY DIC("S")="D PROCSCRN^WVUTL2" IN SCREEN FOR SEVERAL
 ;---> FIELDS IN WV PROCEDURE FILE.
 ;---> REQUIRED VARIABLES: WVPN=IEN OF PROCEDURE TYPE
 ;--->                        Y=IEN OF RES/DIAG BEING SCREENED
 ;---> EACH LINE MAKES THE RES/DIAG AVAILABLE FOR SELECTION IF:
 ;---> 1ST LINE: IF SCREEN VARIABLES ARE UNDEFINED (IE, ALL SELECTABLE).
 ;---> 2ND LINE: IF RES/DIAG IS FOR ALL & THIS PROCEDURE IS NOT EXCLUDED
 ;---> 3RD LINE: IF A "P" XREF FOR THIS PROCEDURE AND RES/DIAG EXISTS.
 ;---> 4TH LINE: OTHERWISE RES/DIAG FAILS SCREEN AND IS NOT SELECTABLE.
 Q:'$D(WVPN)!('$D(Y))
 Q:$P(^WV(790.31,Y,0),U,20)
 Q:$D(^WV(790.31,"P",WVPN,Y))
 I 0
 Q
 ;
PAPSCRN ;EP
 ;---> SCREEN CALLED BY FILEMAN ^DD(790.1,.3
 ;---> SCREEN WHEN SELECTING THE PAP THAT INITIATED THIS COLPOSCOPY.
 ;---> CALLED BY DIC("S")="D PAPSCRN^WVUTL2" IN FIELD .3 OF
 ;---> WV PROCEDURE FILE: FIRST CHECK IF THE PROCEDURE IS FOR THIS
 ;---> PATIENT, THEN MAKE SURE IT'S A PAP.
 Q:$P(^(0),U,2)=WVDFN&($P(^(0),U,4)=1)
 I 0
 Q
 ;