BWUTL2 ;IHS/ANMC/MWR - UTIL: ZIS, XREF, PROSCREEN;17-Apr-2003 12:02;PLS
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* 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(BWPOP,BWQUE,BWDEF,BWPRMPT,BWMES) ;EP
;---> CALL TO ^%ZIS
;---> PARAMETERS:
; 1 - BWPOP (RETURNED) BWPOP=1 IF POP=1 (FAIL OR QUIT).
; 2 - BWQUE=1 (OPTIONAL) SET=1 IF JOB SHOULD BW QUEUEABLE.
; 3 - BWDEF=DEFAULT (OPTIONAL) IF EXISTS, EQUALS DEFAULT DEVICE.
; 4 - BWPRMPT (OPTIONAL) IF EXISTS, EQUALS PROMPT.
; 5 - BWMES (OPTIONAL) A MESSAGE TO DISPLAY IF QUEUED.
;
;---> EXAMPLE: D ZIS^BWUTL2(.BWPOP,1,"HOME")
;
ZIS1 ;EP FOR LOOP BACK FROM FAILED BWQUE.
S BWPOP=0
;
;---> BWPRMPT=BWPRMPT.
S %ZIS("A")=$S($D(BWPRMPT):BWPRMPT,1:" Select DEVICE: ")
;
;---> BWDEF=DEFAULT PRINTER.
;---> IF NO BWDEF, SET BWDEF="P" FOR CLOSEST PRINTER.
D
.I '$D(BWDEF) S %ZIS="P" Q
.S %ZIS("B")=BWDEF,%ZIS=""
;
;---> IF BWQUE=1,JOB MAY BE QUEUED.
I $G(BWQUE)]"" I BWQUE S %ZIS=%ZIS_"Q"
;
W ! D ^%ZIS S:POP BWPOP=1
;---> QUIT IF BWPOP (DUOUT OR DTOUT) OR IF NOT BWQUED.
G:BWPOP!('$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 BWQUED OUTPUT.
ZISQ ;EP
;---> NEXT LINES: JOB WAS QUEUED, THEREFORE SET BWPOP=1 SO THAT THE
;---> CALLING ROUTINE WILL QUIT (AND LET TASKMAN FINISH THIS JOB).
S BWPOP=1
I '$D(ZTRTN) D G ZISEXIT
.W !?5,*7,"NO ROUTINE NAMED FOR QUEUEING -- CONTACT PROGRAMMER."
I '$D(ZTDESC) S ZTDESC=ZTRTN
S BWMES=$S($D(BWMES):BWMES,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
D ^%ZTLOAD,^%ZISC
;---> SET BWPOP=1 TO TELL CALLING ROUTINE TO QUIT (LET TASKMAN FINISH).
S BWPOP=1
X:$D(ZTSK) BWMES H 2
;
ZISEXIT ;EP
K BWMES,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
;
;
XREFP05 ;EP
;---> CALLED BY MUMPS "ABNML" XREF ON FIELD .05 IN FILE 9002086.1.
;---> REINDEX RESULTS FIELD .05 IN BW PROCEDURE FILE, BY DATE
;---> (PIECE 12), WHEN RESULT/DIAGNOSIS IS "ABNORMAL" (AS STORED IN
;---> PIECE 21 OF THE POINTED TO BW RESULTS/DIAGNOSIS ENTRY).
;---> X=IEN BW RESULT/DIAGNOSIS, DA=ENTRY IN BW PROCEDURE FILE.
Q:'$P(^BWPCD(DA,0),U,12)
I $P(^BWDIAG(X,0),U,21) S ^BWPCD("ABNML",$P(^BWPCD(DA,0),U,12),DA)="" Q
K ^BWPCD("ABNML",$P(^BWPCD(DA,0),U,12),DA)
Q
;
XREFP12 ;EP
;---> CALLED BY MUMPS "ABNML1" XREF ON FIELD .12 IN FILE 9002086.1.
;---> LOGIC TO REINDEX RESULTS FIELD .05 IN BW PROCEDURE FILE WHEN
;---> DATE OF PROCEDURE .12 FIELD IS CHANGED. X=NEWDATE, DA=ENTRY.
;---> SEE XREFP05 ABOVE.
I '$P(^BWPCD(DA,0),U,5) S ^BWPCD("ABNML",X,DA)="" Q
I $P(^BWDIAG($P(^BWPCD(DA,0),U,5),0),U,21) S ^BWPCD("ABNML",X,DA)="" Q
K ^BWPCD("ABNML",X,DA)
Q
;
REXREFN ;EP
;---> CALLED BY MUMPS XREF ON FIELD .02 IN FILE 9002086.4.
;---> LOGIC TO REINDEX STATUS FIELD .14 IN BW 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(^BWNOT(DA,0),U,2) K ^BWNOT("AOPEN",$P(^(0),U,2),DA)
I "o"[$P(^BWNOT(DA,0),U,14) S ^BWNOT("AOPEN",X,DA)=""
Q
;
;
PROCSCRN ;EP
;---> SCREEN WHEN SELECTING RESULTS/DIAGNOSIS FOR PROCEDURES.
;---> CALLED BY DIC("S")="D PROCSCRN^BWUTL2" IN SCREEN FOR SEVERAL
;---> FIELDS IN BW PROCEDURE FILE.
;---> REQUIRED VARIABLES: BWPN=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(BWPN)!('$D(Y))
Q:$P(^BWDIAG(Y,0),U,20)
Q:$D(^BWDIAG("P",BWPN,Y))
I 0
Q
;
PAPSCRN ;EP
;---> SCREEN CALLED BY FILEMAN ^DD.
;---> SCREEN WHEN SELECTING THE PAP THAT INITIATED THIS COLPOSCOPY.
;---> CALLED BY DIC("S")="D PAPSCRN^BWUTL2" IN FIELD .3 OF
;---> BW PROCEDURE FILE: FIRST CHECK IF THE PROCEDURE IS FOR THIS
;---> PATIENT, THEN MAKE SURE IT'S A PAP.
Q:$P(^(0),U,2)=+$G(BWDFN)&($P(^(0),U,4)=1)
I 0
Q
;
ERRCD(X,W,Y) ;EP
;---> DISPLAY ERROR CODE FROM BW ERROR CODE FILE.
;---> REQUIRED VARIABLE: X=IEN OF ERROR CODE.
;---> OPTIONAL VARIABLE: W=1 IF TEXT SHOULD NOT BE WRITTEN OUT.
;---> RETURNED VARIABLE: Y=TEXT OF ERROR CODE.
;
S:$G(W)'=1 W=0
I '+$G(X) D ERRW() Q
I '$D(^BWERR(X,0)) D Q
.S Y="Error Code does not exist in BW ERROR CODE File." D:'W ERRW(Y)
S Y=$P(^BWERR(X,0),U,2) D:'W ERRW(Y)
Q
;
ERRW(X) ;EP
;---> WRITE OUT ERROR CODE.
W !!?5,"Data for this Procedure was NOT passed to PCC because:"
I $G(X)']"" W !?5,"NO ERROR CODE PROVIDED.",! Q
W !?5,X,! D DIRZ^BWUTL3
Q
BWUTL2 ;IHS/ANMC/MWR - UTIL: ZIS, XREF, PROSCREEN;17-Apr-2003 12:02;PLS
+1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; UTILITY: ZIS, MUMPS XREFS ON NORMAL/ABNORMAL AND ON STATUS.
+4 ;; PROCSCRN-SCREEN ON RESULT/DIAGNOSIS BASED ON PROCEDURE.
+5 ;
+6 ;
ZIS(BWPOP,BWQUE,BWDEF,BWPRMPT,BWMES) ;EP
+1 ;---> CALL TO ^%ZIS
+2 ;---> PARAMETERS:
+3 ; 1 - BWPOP (RETURNED) BWPOP=1 IF POP=1 (FAIL OR QUIT).
+4 ; 2 - BWQUE=1 (OPTIONAL) SET=1 IF JOB SHOULD BW QUEUEABLE.
+5 ; 3 - BWDEF=DEFAULT (OPTIONAL) IF EXISTS, EQUALS DEFAULT DEVICE.
+6 ; 4 - BWPRMPT (OPTIONAL) IF EXISTS, EQUALS PROMPT.
+7 ; 5 - BWMES (OPTIONAL) A MESSAGE TO DISPLAY IF QUEUED.
+8 ;
+9 ;---> EXAMPLE: D ZIS^BWUTL2(.BWPOP,1,"HOME")
+10 ;
ZIS1 ;EP FOR LOOP BACK FROM FAILED BWQUE.
+1 SET BWPOP=0
+2 ;
+3 ;---> BWPRMPT=BWPRMPT.
+4 SET %ZIS("A")=$SELECT($DATA(BWPRMPT):BWPRMPT,1:" Select DEVICE: ")
+5 ;
+6 ;---> BWDEF=DEFAULT PRINTER.
+7 ;---> IF NO BWDEF, SET BWDEF="P" FOR CLOSEST PRINTER.
+8 Begin DoDot:1
+9 IF '$DATA(BWDEF)
SET %ZIS="P"
QUIT
+10 SET %ZIS("B")=BWDEF
SET %ZIS=""
End DoDot:1
+11 ;
+12 ;---> IF BWQUE=1,JOB MAY BE QUEUED.
+13 IF $GET(BWQUE)]""
IF BWQUE
SET %ZIS=%ZIS_"Q"
+14 ;
+15 WRITE !
DO ^%ZIS
IF POP
SET BWPOP=1
+16 ;---> QUIT IF BWPOP (DUOUT OR DTOUT) OR IF NOT BWQUED.
+17 IF BWPOP!('$DATA(IO("Q")))
GOTO ZISEXIT
+18 ;
+19 IF IO=IO(0)
WRITE !?5,"Cannot queue to screen or slave printer!",!
GOTO ZIS1
+20 ;
+21 ;---> NEXT LINE: LINE LABEL "ZISQ" ADDED FOR ENTRY WHERE DEVICE
+22 ;---> INFO HAS ALREADY BEEN ASKED AND USER BWQUED OUTPUT.
ZISQ ;EP
+1 ;---> NEXT LINES: JOB WAS QUEUED, THEREFORE SET BWPOP=1 SO THAT THE
+2 ;---> CALLING ROUTINE WILL QUIT (AND LET TASKMAN FINISH THIS JOB).
+3 SET BWPOP=1
+4 IF '$DATA(ZTRTN)
Begin DoDot:1
+5 WRITE !?5,*7,"NO ROUTINE NAMED FOR QUEUEING -- CONTACT PROGRAMMER."
End DoDot:1
GOTO ZISEXIT
+6 IF '$DATA(ZTDESC)
SET ZTDESC=ZTRTN
+7 SET BWMES=$SELECT($DATA(BWMES):BWMES,1:"W !?5,""Request Queued."",!")
+8 ;
+9 SET ZTIO=$SELECT($DATA(ION):ION,1:"")
+10 IF ZTIO]""
Begin DoDot:1
+11 IF $DATA(IO("DOC"))
SET ZTIO=ZTIO_";"_IOST_";"_IO("DOC")
QUIT
+12 SET ZTIO=ZTIO_";"_IOST_";"_IOM_";"_IOSL
End DoDot:1
+13 DO ^%ZTLOAD
DO ^%ZISC
+14 ;---> SET BWPOP=1 TO TELL CALLING ROUTINE TO QUIT (LET TASKMAN FINISH).
+15 SET BWPOP=1
+16 IF $DATA(ZTSK)
XECUTE BWMES
HANG 2
+17 ;
ZISEXIT ;EP
+1 KILL BWMES,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 QUIT
+3 ;
+4 ;
XREFP05 ;EP
+1 ;---> CALLED BY MUMPS "ABNML" XREF ON FIELD .05 IN FILE 9002086.1.
+2 ;---> REINDEX RESULTS FIELD .05 IN BW PROCEDURE FILE, BY DATE
+3 ;---> (PIECE 12), WHEN RESULT/DIAGNOSIS IS "ABNORMAL" (AS STORED IN
+4 ;---> PIECE 21 OF THE POINTED TO BW RESULTS/DIAGNOSIS ENTRY).
+5 ;---> X=IEN BW RESULT/DIAGNOSIS, DA=ENTRY IN BW PROCEDURE FILE.
+6 IF '$PIECE(^BWPCD(DA,0),U,12)
QUIT
+7 IF $PIECE(^BWDIAG(X,0),U,21)
SET ^BWPCD("ABNML",$PIECE(^BWPCD(DA,0),U,12),DA)=""
QUIT
+8 KILL ^BWPCD("ABNML",$PIECE(^BWPCD(DA,0),U,12),DA)
+9 QUIT
+10 ;
XREFP12 ;EP
+1 ;---> CALLED BY MUMPS "ABNML1" XREF ON FIELD .12 IN FILE 9002086.1.
+2 ;---> LOGIC TO REINDEX RESULTS FIELD .05 IN BW PROCEDURE FILE WHEN
+3 ;---> DATE OF PROCEDURE .12 FIELD IS CHANGED. X=NEWDATE, DA=ENTRY.
+4 ;---> SEE XREFP05 ABOVE.
+5 IF '$PIECE(^BWPCD(DA,0),U,5)
SET ^BWPCD("ABNML",X,DA)=""
QUIT
+6 IF $PIECE(^BWDIAG($PIECE(^BWPCD(DA,0),U,5),0),U,21)
SET ^BWPCD("ABNML",X,DA)=""
QUIT
+7 KILL ^BWPCD("ABNML",X,DA)
+8 QUIT
+9 ;
REXREFN ;EP
+1 ;---> CALLED BY MUMPS XREF ON FIELD .02 IN FILE 9002086.4.
+2 ;---> LOGIC TO REINDEX STATUS FIELD .14 IN BW NOTIFICATION FILE
+3 ;---> WHEN DATE NOTIFICATION OPENED .02 FIELD IS CHANGED.
+4 ;---> X=NEWDATE, DA=ENTRY.
+5 ;---> NOTE: IF STATUS IS NULL XREF FOR "AOPEN" GETS SET HERE.
+6 IF $PIECE(^BWNOT(DA,0),U,2)
KILL ^BWNOT("AOPEN",$PIECE(^(0),U,2),DA)
+7 IF "o"[$PIECE(^BWNOT(DA,0),U,14)
SET ^BWNOT("AOPEN",X,DA)=""
+8 QUIT
+9 ;
+10 ;
PROCSCRN ;EP
+1 ;---> SCREEN WHEN SELECTING RESULTS/DIAGNOSIS FOR PROCEDURES.
+2 ;---> CALLED BY DIC("S")="D PROCSCRN^BWUTL2" IN SCREEN FOR SEVERAL
+3 ;---> FIELDS IN BW PROCEDURE FILE.
+4 ;---> REQUIRED VARIABLES: BWPN=IEN OF PROCEDURE TYPE
+5 ;---> Y=IEN OF RES/DIAG BEING SCREENED
+6 ;---> EACH LINE MAKES THE RES/DIAG AVAILABLE FOR SELECTION IF:
+7 ;---> 1ST LINE: IF SCREEN VARIABLES ARE UNDEFINED (IE, ALL SELECTABLE).
+8 ;---> 2ND LINE: IF RES/DIAG IS FOR ALL & THIS PROCEDURE IS NOT EXCLUDED
+9 ;---> 3RD LINE: IF A "P" XREF FOR THIS PROCEDURE AND RES/DIAG EXISTS.
+10 ;---> 4TH LINE: OTHERWISE RES/DIAG FAILS SCREEN AND IS NOT SELECTABLE.
+11 IF '$DATA(BWPN)!('$DATA(Y))
QUIT
+12 IF $PIECE(^BWDIAG(Y,0),U,20)
QUIT
+13 IF $DATA(^BWDIAG("P",BWPN,Y))
QUIT
+14 IF 0
+15 QUIT
+16 ;
PAPSCRN ;EP
+1 ;---> SCREEN CALLED BY FILEMAN ^DD.
+2 ;---> SCREEN WHEN SELECTING THE PAP THAT INITIATED THIS COLPOSCOPY.
+3 ;---> CALLED BY DIC("S")="D PAPSCRN^BWUTL2" IN FIELD .3 OF
+4 ;---> BW PROCEDURE FILE: FIRST CHECK IF THE PROCEDURE IS FOR THIS
+5 ;---> PATIENT, THEN MAKE SURE IT'S A PAP.
+6 IF $PIECE(^(0),U,2)=+$GET(BWDFN)&($PIECE(^(0),U,4)=1)
QUIT
+7 IF 0
+8 QUIT
+9 ;
ERRCD(X,W,Y) ;EP
+1 ;---> DISPLAY ERROR CODE FROM BW ERROR CODE FILE.
+2 ;---> REQUIRED VARIABLE: X=IEN OF ERROR CODE.
+3 ;---> OPTIONAL VARIABLE: W=1 IF TEXT SHOULD NOT BE WRITTEN OUT.
+4 ;---> RETURNED VARIABLE: Y=TEXT OF ERROR CODE.
+5 ;
+6 IF $GET(W)'=1
SET W=0
+7 IF '+$GET(X)
DO ERRW()
QUIT
+8 IF '$DATA(^BWERR(X,0))
Begin DoDot:1
+9 SET Y="Error Code does not exist in BW ERROR CODE File."
IF 'W
DO ERRW(Y)
End DoDot:1
QUIT
+10 SET Y=$PIECE(^BWERR(X,0),U,2)
IF 'W
DO ERRW(Y)
+11 QUIT
+12 ;
ERRW(X) ;EP
+1 ;---> WRITE OUT ERROR CODE.
+2 WRITE !!?5,"Data for this Procedure was NOT passed to PCC because:"
+3 IF $GET(X)']""
WRITE !?5,"NO ERROR CODE PROVIDED.",!
QUIT
+4 WRITE !?5,X,!
DO DIRZ^BWUTL3
+5 QUIT
