PSJRXLAB ;ALB/RTW - drug+lab result print ; 12/8/18 10:36am
;;5.0;INPATIENT MEDICATIONS;**327**;DEC 1997;Build 114
;RTW copied from routine PSORXLAB and modified for the Inpatient NCC Clozapine inpatient pharmacy project
;FSIG and FSIG2(formerly EN2), are brought in from PSOUTLA and PSOUTLA1
;a routine which loop thru the last fill order of ^PS(55 and gets
;patients with a specific drug. then gets the lrdfn from the
;patient file and loops thru the patients lab data to find
;results within the date range you specify for the lab test
;used to minitor the drug. it then prints the patient's name
;ssn, last fill date, and the lab test results if any.
;this is intended as a qa minitor and should not be run for
;more than a 30 day fill date interval, or 1 year lab test interval.
;External ref. to ^LAB(60, is supp. by DBIA# 333
;External ref. to ^LR(LRDFN,"CH", is supp. by DBIA# 844
;External ref. to ^PSDRUG( is supp. by DBIA# 221
;External ref. to ^VA(200, is supp. by DBIA# 10060
PSJSITE K ^UTILITY("DIQ1",$J),DIQ,^TMP($J,"ORDERNUM") S DA=$P($$SITE^VASITE(),"^")
N PSCNT S PSCNT=0
I $G(DA) D
.S DIC=4,DIQ(0)="I",DR=".01;99" D EN^DIQ1
.S SITE=$G(^UTILITY("DIQ1",$J,4,DA,.01,"I"))_" "_$G(^UTILITY("DIQ1",$J,4,DA,99,"I"))
.K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
S Y=DT X ^DD("DD") S SITE=$G(SITE)_" "_Y
BDATE S %DT="EXTA",%DT("A")="Beginning fill date: " D ^%DT G CLEAN:Y<0 S PSJBD=Y X ^DD("DD") S PSJBDR=Y
EDATE S %DT("A")="Ending last fill date: " D ^%DT G CLEAN:Y<0 S PSJED=Y X ^DD("DD") S PSJEDR=Y
LDATE S %DT("A")="Earliest date for lab results: " D ^%DT G CLEAN:Y<0 S LDATE=Y X ^DD("DD") S LDATER=Y
DRUG R !,"Enter the key word in the Drug Generic name: ",PSJDRUG:DTIME G CLEAN:'$T I "^"[PSJDRUG G CLEAN
N DRGARRAY D LIST^DIC(50,,.01,"I",,,$$UP^XLFSTR(PSJDRUG),"B",,,"DRGARRAY")
I 'DRGARRAY("DILIST",0) W !,"No corresponding entry, try again or type return to exit" G DRUG
S PSJDRUG=$$UP^XLFSTR(PSJDRUG)
LABT S DIC="^LAB(60,",DIC(0)="QEAM" D ^DIC K DIC G:Y<0 CLEAN S PSJLBT=$P(Y,"^"),PSJLABTN=$P(Y,"^",2) G:PSJLBT="" CLEAN
;I '$D(^LAB(60,PSJLBT,.2)) W !!,$C(7),"Data Name missing !!",! K Y,PSJLBT G LABT
S PSJLABT=$$GET1^DIQ(60,PSJLBT,400,"I")
W !,"Enter the specimen used in the lab for this test, serum, plasma, blood etc."
PSJSP S DIC="^LAB(61,",DIC(0)="QEAM" D ^DIC G:Y<0 CLEAN S PSJSP=$P(Y,"^") G:PSJSP="" CLEAN ;;I $P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7)']"" W !!,$C(7),"Specimen data missing !!",! ;K Y,PSJSP G PSJSP
PSJUNIT S PSJUNIT=$S($G(PSJSP)]"":$$GET1^DIQ(60.01,PSJSP_","_PSJLBT,6),1:"")
PSJANS R !,"Do you want Order info? N// ",PSJANS:DTIME G CLEAN:'$T S:PSJANS="" PSJANS="N" G:PSJANS="^" CLEAN2 I "YNyn"'[$E(PSJANS) W !,"ANSWER YES OR NO" G PSJANS
DEVICE K IOP S %ZIS="MQ" D ^%ZIS G:POP CLEAN2
I $D(IO("Q")) K IO("Q") S ZTSAVE("*")="",ZTRTN="DQ^PSJRXLAB",ZTDESC="LAB LIST" D ^%ZTLOAD K ZTSK G CLEAN
DQ S PSJLABQ=0 S PSJBD=PSJBD-1,PAGE=0 U IO W @IOF D HDR
LOOP1 ;
K ^TMP($J,"PSORDT") D LIST^DIC(100,"",.01,"I",,PSJBD,,"AD",,,"^TMP($J,""PSORDT"")")
N PSJ F PSJ=1:1 Q:'$D(^TMP($J,"PSORDT","DILIST",1,PSJ)) S PSJBD=^TMP($J,"PSORDT","DILIST",1,PSJ) Q:PSJBD>PSJED S PSJORDN=0 D LOOP2 Q:$G(PSJLABQ)
G CLEAN
LOOP2 S PSJORDN=^TMP($J,"PSORDT","DILIST",2,PSJ) D CHECK1
Q
CHECK1 ;
N PSJNUM
S PSJNUM=$$FIND1^DIC(100.045,","_PSJORDN_",","X","DRUG","ID") Q:'PSJNUM
S PSCNT=PSCNT+1
S ^TMP($J,"ORDERNUM",PSCNT)=PSJORDN
S PSJDGN=$$GET1^DIQ(100.045,PSJNUM_","_PSJORDN,1,"I"),PSJDRUGN=$$GET1^DIQ(50,PSJDGN,.01)
Q:'$G(PSJDGN) I PSJDRUGN'[PSJDRUG Q
S PSJPROV=$$GET1^DIQ(100,PSJORDN,1,"I") Q:'PSJPROV
S PSJPROVN=$$GET1^DIQ(200,PSJPROV,.01),PSJPROT=$$GET1^DIQ(200,PSJPROV,9.21,"I")
S PSJTYPE="NONE" I PSJPROT S PSJTYPE=$P("FULL TIME^PART TIME^C & A^FEE^STAFF","^",PSJPROT)
CHECK2 ;
S PSJPT=+$$GET1^DIQ(100,PSJORDN,.02,"I") Q:'PSJPT W ! S DFN=PSJPT D PID^VADPT,PRINT2
S LRDFN=$$GET1^DIQ(2,PSJPT,63,"I")
I 'LRDFN W ?55,"No lab data exists",?81,$E(PSJPROVN,1,20),?106,PSJTYPE,! D:PSJANS["Y"!(PSJANS["y") PSJORDNI Q
S PSJLBENT=0,PSJINDIC=0
LOOP3 ;
N LRARRAY,RESULT D LIST^DIC(63.04,","_LRDFN_",",,"I",,LDATE,,,,,"LRARRAY")
F J2=1:1 Q:'$D(LRARRAY("DILIST",1,J2)) S PSJLDATE=LRARRAY("DILIST",1,J2) Q:PSJLDATE>PSJBD
I J2>1 S J2=J2-1,PSJLDATE=LRARRAY("DILIST",1,J2),PSJLBENT=LRARRAY("DILIST",2,J2) D CHECK3 Q:$G(PSJLABQ)
I PSJINDIC=0 W ?55,"NO LAB DATA IN RANGE",?81,$E(PSJPROVN,1,20),?106,PSJTYPE,!
D:PSJANS["Y" PSJORDNI
I $D(RESULT(3)) F J4=3:1 Q:'$D(RESULT(J4)) W ?55,RESULT(J4),! I $Y>(IOSL-6) D Q:$G(PSJLABQ) W @IOF,SITE,! D HDR2
.I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLABQ=1
Q
CHECK3 ;
N ARR,KEY,TERM K RESULT S RESULT="",KEY=PSJLBENT_","_LRDFN D GETS^DIQ(63.04,KEY,"*","I","ARR") S KEY=KEY_","
; Loading of multiple results commented out MZR
;S J3=1 F S J3=$O(ARR(63.04,KEY,J3)) Q:'J3 I ARR(63.04,KEY,J3,"I") D
;.I RESULT'="" S RESULT($I(TERM))=$P(^DD(63.04,J3,0),"^")_":"_ARR(63.04,KEY,J3,"I") Q
;.S RESULT=$P(^DD(63.04,J3,0),"^")_":"_ARR(63.04,KEY,J3,"I")
I $D(ARR(63.04,KEY,PSJLABT,"I")) S RESULT=$P(^DD(63.04,PSJLABT,0),"^")_":"_ARR(63.04,KEY,PSJLABT,"I")
I RESULT'="" D RESULT
Q
RESULT Q:ARR(63.04,KEY,.05,"I")'=PSJSP Q:'ARR(63.04,KEY,.03,"I")
S Y=PSJLDATE X ^DD("DD") W ?55,$E(Y,1,11),?68,RESULT,! ;$P(^LR(LRDFN,"CH",PSJLBENT,PSJLABT),"^")_" "_PSJUNIT,?81,$E(PSJPROVN,1,20),?106,PSJTYPE W !
S PSJINDIC=1 Q
Q
PRINT2 I $Y>(IOSL-6) D Q:$G(PSJLABQ) W @IOF,SITE,! D HDR2
.I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLABQ=1
W ?1,$E($$GET1^DIQ(2,PSJPT,.01),1,20),?25,VA("PID") S Y=PSJBD X ^DD("DD") W ?37,Y
Q
HDR W SITE,!!,"Patients receiving "_PSJDRUG_" with fills between "_PSJBDR_" and "_PSJEDR,!," with date of collection and results for lab test "_PSJLABTN_" after ",LDATER,!
HDR2 S PAGE=PAGE+1 W !,"Name",?25,"ID#",?37,"Fill Date",?55,"Lab Date",?68,"Results",?81,"Order Provider",?106,"Type",?116,"Page "_PAGE,!
F J=1:1:IOM-1 W "_"
W ! Q
PSJORDNI N DTOUT,DUOUT Q:$G(PSJLABQ) W "Order #: "_$$GET1^DIQ(100,PSJORDN,.01)_" Drug: "_$$GET1^DIQ(50,PSJDGN,.01)
I $D(RESULT)>1 W ?55,RESULT(1)
N SIGNUM S SIGNUM=$$FIND1^DIC(100.045,","_PSJORDN_",","X","SIG","ID")
W !?1,"Sig: ",$$GET1^DIQ(100.0451,"1,"_SIGNUM_","_PSJORDN,.01)
I $D(RESULT(2)) W ?55,RESULT(2)
I $Y>(IOSL-6) D Q:$G(PSJLABQ) W @IOF,SITE,! D HDR2
.I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLABQ=1
W ! Q
CLEAN I $L($G(IOF)) W @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
CLEAN2 K PSJINDIC,PSJPT,PSJLDATE,PAGE,PSJBD,PSJBDR,PSJLBENT,PSJLABT,PSJDGN,PSJDRUGN,PSJDRUG,J,J1,J2,PSJORDN,PSJPROV,PSJPROVN,LDATE,LDATER,PSJED,PSJEDR,PSJPROT,PSJTYPE,PSJLABTN,PSJLBT,PSJSP,PSJUNIT,PSJANS,DIC,LRDFN,POP,SITE,Y,%DT,PSJLABQ
K ZTDESC,ZTRTN,ZTSAVE,%ZIS,^TMP($J,"ORDERNUM"),^TMP($J,"PSORDT") Q
;
FQUIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJRXLAB 6822 printed Sep 23, 2025@19:45:12 Page 2
PSJRXLAB ;ALB/RTW - drug+lab result print ; 12/8/18 10:36am
+1 ;;5.0;INPATIENT MEDICATIONS;**327**;DEC 1997;Build 114
+2 ;RTW copied from routine PSORXLAB and modified for the Inpatient NCC Clozapine inpatient pharmacy project
+3 ;FSIG and FSIG2(formerly EN2), are brought in from PSOUTLA and PSOUTLA1
+4 ;a routine which loop thru the last fill order of ^PS(55 and gets
+5 ;patients with a specific drug. then gets the lrdfn from the
+6 ;patient file and loops thru the patients lab data to find
+7 ;results within the date range you specify for the lab test
+8 ;used to minitor the drug. it then prints the patient's name
+9 ;ssn, last fill date, and the lab test results if any.
+10 ;this is intended as a qa minitor and should not be run for
+11 ;more than a 30 day fill date interval, or 1 year lab test interval.
+12 ;External ref. to ^LAB(60, is supp. by DBIA# 333
+13 ;External ref. to ^LR(LRDFN,"CH", is supp. by DBIA# 844
+14 ;External ref. to ^PSDRUG( is supp. by DBIA# 221
+15 ;External ref. to ^VA(200, is supp. by DBIA# 10060
PSJSITE KILL ^UTILITY("DIQ1",$JOB),DIQ,^TMP($JOB,"ORDERNUM")
SET DA=$PIECE($$SITE^VASITE(),"^")
+1 NEW PSCNT
SET PSCNT=0
+2 IF $GET(DA)
Begin DoDot:1
+3 SET DIC=4
SET DIQ(0)="I"
SET DR=".01;99"
DO EN^DIQ1
+4 SET SITE=$GET(^UTILITY("DIQ1",$JOB,4,DA,.01,"I"))_" "_$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
+5 KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIQ,DIC
End DoDot:1
+6 SET Y=DT
XECUTE ^DD("DD")
SET SITE=$GET(SITE)_" "_Y
BDATE SET %DT="EXTA"
SET %DT("A")="Beginning fill date: "
DO ^%DT
if Y<0
GOTO CLEAN
SET PSJBD=Y
XECUTE ^DD("DD")
SET PSJBDR=Y
EDATE SET %DT("A")="Ending last fill date: "
DO ^%DT
if Y<0
GOTO CLEAN
SET PSJED=Y
XECUTE ^DD("DD")
SET PSJEDR=Y
LDATE SET %DT("A")="Earliest date for lab results: "
DO ^%DT
if Y<0
GOTO CLEAN
SET LDATE=Y
XECUTE ^DD("DD")
SET LDATER=Y
DRUG READ !,"Enter the key word in the Drug Generic name: ",PSJDRUG:DTIME
if '$TEST
GOTO CLEAN
IF "^"[PSJDRUG
GOTO CLEAN
+1 NEW DRGARRAY
DO LIST^DIC(50,,.01,"I",,,$$UP^XLFSTR(PSJDRUG),"B",,,"DRGARRAY")
+2 IF 'DRGARRAY("DILIST",0)
WRITE !,"No corresponding entry, try again or type return to exit"
GOTO DRUG
+3 SET PSJDRUG=$$UP^XLFSTR(PSJDRUG)
LABT SET DIC="^LAB(60,"
SET DIC(0)="QEAM"
DO ^DIC
KILL DIC
if Y<0
GOTO CLEAN
SET PSJLBT=$PIECE(Y,"^")
SET PSJLABTN=$PIECE(Y,"^",2)
if PSJLBT=""
GOTO CLEAN
+1 ;I '$D(^LAB(60,PSJLBT,.2)) W !!,$C(7),"Data Name missing !!",! K Y,PSJLBT G LABT
+2 SET PSJLABT=$$GET1^DIQ(60,PSJLBT,400,"I")
+3 WRITE !,"Enter the specimen used in the lab for this test, serum, plasma, blood etc."
PSJSP ;;I $P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7)']"" W !!,$C(7),"Specimen data missing !!",! ;K Y,PSJSP G PSJSP
SET DIC="^LAB(61,"
SET DIC(0)="QEAM"
DO ^DIC
if Y<0
GOTO CLEAN
SET PSJSP=$PIECE(Y,"^")
if PSJSP=""
GOTO CLEAN
PSJUNIT SET PSJUNIT=$SELECT($GET(PSJSP)]"":$$GET1^DIQ(60.01,PSJSP_","_PSJLBT,6),1:"")
PSJANS READ !,"Do you want Order info? N// ",PSJANS:DTIME
if '$TEST
GOTO CLEAN
if PSJANS=""
SET PSJANS="N"
if PSJANS="^"
GOTO CLEAN2
IF "YNyn"'[$EXTRACT(PSJANS)
WRITE !,"ANSWER YES OR NO"
GOTO PSJANS
DEVICE KILL IOP
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO CLEAN2
+1 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTSAVE("*")=""
SET ZTRTN="DQ^PSJRXLAB"
SET ZTDESC="LAB LIST"
DO ^%ZTLOAD
KILL ZTSK
GOTO CLEAN
DQ SET PSJLABQ=0
SET PSJBD=PSJBD-1
SET PAGE=0
USE IO
WRITE @IOF
DO HDR
LOOP1 ;
+1 KILL ^TMP($JOB,"PSORDT")
DO LIST^DIC(100,"",.01,"I",,PSJBD,,"AD",,,"^TMP($J,""PSORDT"")")
+2 NEW PSJ
FOR PSJ=1:1
if '$DATA(^TMP($JOB,"PSORDT","DILIST",1,PSJ))
QUIT
SET PSJBD=^TMP($JOB,"PSORDT","DILIST",1,PSJ)
if PSJBD>PSJED
QUIT
SET PSJORDN=0
DO LOOP2
if $GET(PSJLABQ)
QUIT
+3 GOTO CLEAN
LOOP2 SET PSJORDN=^TMP($JOB,"PSORDT","DILIST",2,PSJ)
DO CHECK1
+1 QUIT
CHECK1 ;
+1 NEW PSJNUM
+2 SET PSJNUM=$$FIND1^DIC(100.045,","_PSJORDN_",","X","DRUG","ID")
if 'PSJNUM
QUIT
+3 SET PSCNT=PSCNT+1
+4 SET ^TMP($JOB,"ORDERNUM",PSCNT)=PSJORDN
+5 SET PSJDGN=$$GET1^DIQ(100.045,PSJNUM_","_PSJORDN,1,"I")
SET PSJDRUGN=$$GET1^DIQ(50,PSJDGN,.01)
+6 if '$GET(PSJDGN)
QUIT
IF PSJDRUGN'[PSJDRUG
QUIT
+7 SET PSJPROV=$$GET1^DIQ(100,PSJORDN,1,"I")
if 'PSJPROV
QUIT
+8 SET PSJPROVN=$$GET1^DIQ(200,PSJPROV,.01)
SET PSJPROT=$$GET1^DIQ(200,PSJPROV,9.21,"I")
+9 SET PSJTYPE="NONE"
IF PSJPROT
SET PSJTYPE=$PIECE("FULL TIME^PART TIME^C & A^FEE^STAFF","^",PSJPROT)
CHECK2 ;
+1 SET PSJPT=+$$GET1^DIQ(100,PSJORDN,.02,"I")
if 'PSJPT
QUIT
WRITE !
SET DFN=PSJPT
DO PID^VADPT
DO PRINT2
+2 SET LRDFN=$$GET1^DIQ(2,PSJPT,63,"I")
+3 IF 'LRDFN
WRITE ?55,"No lab data exists",?81,$EXTRACT(PSJPROVN,1,20),?106,PSJTYPE,!
if PSJANS["Y"!(PSJANS["y")
DO PSJORDNI
QUIT
+4 SET PSJLBENT=0
SET PSJINDIC=0
LOOP3 ;
+1 NEW LRARRAY,RESULT
DO LIST^DIC(63.04,","_LRDFN_",",,"I",,LDATE,,,,,"LRARRAY")
+2 FOR J2=1:1
if '$DATA(LRARRAY("DILIST",1,J2))
QUIT
SET PSJLDATE=LRARRAY("DILIST",1,J2)
if PSJLDATE>PSJBD
QUIT
+3 IF J2>1
SET J2=J2-1
SET PSJLDATE=LRARRAY("DILIST",1,J2)
SET PSJLBENT=LRARRAY("DILIST",2,J2)
DO CHECK3
if $GET(PSJLABQ)
QUIT
+4 IF PSJINDIC=0
WRITE ?55,"NO LAB DATA IN RANGE",?81,$EXTRACT(PSJPROVN,1,20),?106,PSJTYPE,!
+5 if PSJANS["Y"
DO PSJORDNI
+6 IF $DATA(RESULT(3))
FOR J4=3:1
if '$DATA(RESULT(J4))
QUIT
WRITE ?55,RESULT(J4),!
IF $Y>(IOSL-6)
Begin DoDot:1
+7 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET PSJLABQ=1
End DoDot:1
if $GET(PSJLABQ)
QUIT
WRITE @IOF,SITE,!
DO HDR2
+8 QUIT
CHECK3 ;
+1 NEW ARR,KEY,TERM
KILL RESULT
SET RESULT=""
SET KEY=PSJLBENT_","_LRDFN
DO GETS^DIQ(63.04,KEY,"*","I","ARR")
SET KEY=KEY_","
+2 ; Loading of multiple results commented out MZR
+3 ;S J3=1 F S J3=$O(ARR(63.04,KEY,J3)) Q:'J3 I ARR(63.04,KEY,J3,"I") D
+4 ;.I RESULT'="" S RESULT($I(TERM))=$P(^DD(63.04,J3,0),"^")_":"_ARR(63.04,KEY,J3,"I") Q
+5 ;.S RESULT=$P(^DD(63.04,J3,0),"^")_":"_ARR(63.04,KEY,J3,"I")
+6 IF $DATA(ARR(63.04,KEY,PSJLABT,"I"))
SET RESULT=$PIECE(^DD(63.04,PSJLABT,0),"^")_":"_ARR(63.04,KEY,PSJLABT,"I")
+7 IF RESULT'=""
DO RESULT
+8 QUIT
RESULT if ARR(63.04,KEY,.05,"I")'=PSJSP
QUIT
if 'ARR(63.04,KEY,.03,"I")
QUIT
+1 ;$P(^LR(LRDFN,"CH",PSJLBENT,PSJLABT),"^")_" "_PSJUNIT,?81,$E(PSJPROVN,1,20),?106,PSJTYPE W !
SET Y=PSJLDATE
XECUTE ^DD("DD")
WRITE ?55,$EXTRACT(Y,1,11),?68,RESULT,!
+2 SET PSJINDIC=1
QUIT
+3 QUIT
PRINT2 IF $Y>(IOSL-6)
Begin DoDot:1
+1 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET PSJLABQ=1
End DoDot:1
if $GET(PSJLABQ)
QUIT
WRITE @IOF,SITE,!
DO HDR2
+2 WRITE ?1,$EXTRACT($$GET1^DIQ(2,PSJPT,.01),1,20),?25,VA("PID")
SET Y=PSJBD
XECUTE ^DD("DD")
WRITE ?37,Y
+3 QUIT
HDR WRITE SITE,!!,"Patients receiving "_PSJDRUG_" with fills between "_PSJBDR_" and "_PSJEDR,!," with date of collection and results for lab test "_PSJLABTN_" after ",LDATER,!
HDR2 SET PAGE=PAGE+1
WRITE !,"Name",?25,"ID#",?37,"Fill Date",?55,"Lab Date",?68,"Results",?81,"Order Provider",?106,"Type",?116,"Page "_PAGE,!
+1 FOR J=1:1:IOM-1
WRITE "_"
+2 WRITE !
QUIT
PSJORDNI NEW DTOUT,DUOUT
if $GET(PSJLABQ)
QUIT
WRITE "Order #: "_$$GET1^DIQ(100,PSJORDN,.01)_" Drug: "_$$GET1^DIQ(50,PSJDGN,.01)
+1 IF $DATA(RESULT)>1
WRITE ?55,RESULT(1)
+2 NEW SIGNUM
SET SIGNUM=$$FIND1^DIC(100.045,","_PSJORDN_",","X","SIG","ID")
+3 WRITE !?1,"Sig: ",$$GET1^DIQ(100.0451,"1,"_SIGNUM_","_PSJORDN,.01)
+4 IF $DATA(RESULT(2))
WRITE ?55,RESULT(2)
+5 IF $Y>(IOSL-6)
Begin DoDot:1
+6 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET PSJLABQ=1
End DoDot:1
if $GET(PSJLABQ)
QUIT
WRITE @IOF,SITE,!
DO HDR2
+7 WRITE !
QUIT
CLEAN IF $LENGTH($GET(IOF))
WRITE @IOF
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
CLEAN2 KILL PSJINDIC,PSJPT,PSJLDATE,PAGE,PSJBD,PSJBDR,PSJLBENT,PSJLABT,PSJDGN,PSJDRUGN,PSJDRUG,J,J1,J2,PSJORDN,PSJPROV,PSJPROVN,LDATE,LDATER,PSJED,PSJEDR,PSJPROT,PSJTYPE,PSJLABTN,PSJLBT,PSJSP,PSJUNIT,PSJANS,DIC,LRDFN,POP,SITE,Y,%DT,PSJLABQ
+1 KILL ZTDESC,ZTRTN,ZTSAVE,%ZIS,^TMP($JOB,"ORDERNUM"),^TMP($JOB,"PSORDT")
QUIT
+2 ;
FQUIT QUIT
