- PSODDPR3 ;BIR/SAB - display NVA enhanced order checks ;10/04/06 3:38pm
- ;;7.0;OUTPATIENT PHARMACY;**251,375,379,372,651**;DEC 1997;Build 30
- ;Reference ^PSDRUG supported by DBIA 221
- ;Reference ^PS(55 supported by DBIA 2228
- ;Reference ^PS(50.7 is supported by DBIA 2223
- ;Reference ^PS(50.606 supported by DBIA 2174
- NVA S DUPRX0=^PS(55,PSODFN,"NVA",$P(ON,";",2),0) N NVAQ
- S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) ! I '$P(DUPRX0,"^",2) W:'$G(PSODUPF) $J("Non-VA Med: ",20)_$P(^PS(50.7,$P(DUPRX0,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
- E S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) $J("Non-VA Med: ",20)_$P(^PSDRUG($P(DUPRX0,"^",2),0),"^")
- ;W " (Active)"
- S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,$J("Dosage: ",20)_$S($P(DUPRX0,"^",3)]"":$P(DUPRX0,"^",3),1:"<NOT ENTERED>"),$J("Schedule: ",20)_$S($P(DUPRX0,"^",5)]"":$P(DUPRX0,"^",5),1:"<NOT ENTERED>")
- K DSC,DSPL,CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG
- K LST,THER,THERO,^UTILITY($J),DGI,SER,SEV,SERS,BSIG,I,NODDERR,NODTERR,PDRG,DRGI,IZ
- K ^UTILITY($J,"W"),X,ZX,DIWL,DIWR,DIWF
- Q
- MON ;print monograph
- Q:$G(PSODLQT)
- N MONQ,DRGINFO,PVAGDRG,PVAGDRG,VAGDRG,MDRGCNT,MONSEV,PSOMON1,MONTITLE,FDBSEV,SMONTI,MONQ K DIR S DIR(0)="Y",DIR("A")="Display Interaction Monograph",DIR("B")="No" D ^DIR
- S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 W:$G(PSODLQT) !,PSONULN,! K DIR,DTOUT,DUOUT,DIRUT Q:'Y!($G(PSODLQT))
- ;ADD OUTPUT DEVICE
- K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS
- I POP W !,"NOTHING PRINTED" Q
- E W !
- I $D(IO("Q")) D Q
- .S ZTRTN="QUE^PSODDPR3",ZTDESC="Monograph Report of Drug Interactions",ZTSAVE("PSONULN")="",ZTSAVE("SEV")="",ZTSAVE("LIST")=""
- .S ZTSAVE("^TMP($J,LIST,""OUT"",""DRUGDRUG"",SV,DRG,ON,")="",ZTSAVE("ON")="",ZTSAVE("DRG")="",ZTSAVE("CT")="",ZTSAVE("PDRG")=""
- .S ZTSAVE("^TMP($J,""OUT"",""REMOTE"",")="",ZTSAVE("SV")=""
- .D ^%ZTLOAD,^%ZISC W !,"Monograph Queued to Print!",!
- .S:$D(ZTQUEUED) ZTREQ="Q"
- D QUE,^%ZISC
- I $E(IOST)="C",'$G(PSOMONQ) K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to continue" D ^DIR W @IOF S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 K DIR,DTOUT,DUOUT,DIRUT
- K DIR,DTOUT,DUOUT,^UTILITY($J),DIWL,DIWR,DIWF,X,QX,PMON,RDI,^TMP($J,LIST,"PMON"),RMRX,PSOMON1,PSOMONQ,MONQ,FDBSEV,MONTITLE,SMONTI
- Q
- ;
- QUE S (CT,PMON,MDRGCNT)=0 K ^TMP($J,LIST,"PMON")
- U IO
- ;sort to attain an array of FDBSEV by drug and monograph title. Note that the PMON array is already sorted by Vista Severity
- F S CT=$O(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT)) Q:'CT D
- . I $D(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",5,0)) S MONSEV="",MONSEV=^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",5,0) D
- ..S FDBSEV=$P($P(MONSEV,"SEVERITY LEVEL: ",2),"-",1),FDBSEV=$TR(FDBSEV," ","") S:'$G(FDBSEV) FDBSEV=999999999
- ..S MONTITLE="",MONTITLE=$G(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",3,0)),MONTITLE=$P(MONTITLE,"MONOGRAPH TITLE: ",2)
- ..S:MONTITLE="" MONTITLE="Zz No title given"
- ..S PSOMON1(DRG,MONTITLE,FDBSEV)=""
- Q:$G(PSODLQT)
- ;sort "PMON" nodes by drug and FDB severity then print monograph; MDRGCNT = monograph drug count - sequential number counting monographs per drug. If multiple monographs fro same drug allows display of each.
- ;; PMON = counter of # of lines in the monograph to be displayed; FDBSEV = FDB severity for each monograph within the Vista severity
- F S CT=$O(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT)) Q:'CT!$G(PSODLQT) D S PMON=PMON+1,^TMP($J,LIST,"PMON",PMON,0)=""
- .S DRGINFO=^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT),PDRGIEN=$P(DRGINFO,"^",2),DRGIEN=$P(DRGINFO,"^",3)
- .S PVAGDRG=$$GET1^DIQ(50,PDRGIEN,20,"E"),VAGDRG=$$GET1^DIQ(50,DRGIEN,20,"E"),MDRGCNT=MDRGCNT+1
- .I PVAGDRG="" S PVAGDRG=$P(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT),"^",4)
- .I VAGDRG="" S VAGDRG=DRG
- .S SMONTI=$G(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",3,0)),SMONTI=$P(SMONTI,"MONOGRAPH TITLE: ",2)
- .I $D(PSOMON1(DRG,SMONTI)) S FDBSEV="",FDBSEV=$O(PSOMON1(DRG,SMONTI,FDBSEV))
- .S PMON=PMON+1,^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=PSONULN
- .S PMON=PMON+1,^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)="Professional Monograph",PMON=PMON+1
- .S ^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)="Drug Interaction with "_PVAGDRG_" and "_VAGDRG,PMON=PMON+1,^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=""
- .F QX=0:0 S QX=$O(^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",QX)) Q:'QX D FPMON
- Q:'$O(^TMP($J,LIST,"PMON",0))!$G(PSODLQT)
- K DIR,DTOUT,DUOUT,MONQ U IO W @IOF
- I $P(ON,";")="R" S RMRX=$P(^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2)),"^",5)
- ;display monograph detailed information
- F FDBSEV=0:0 S FDBSEV=$O(^TMP($J,LIST,"PMON",FDBSEV)) Q:FDBSEV=""!($G(MONQ)) F QXX=0:0 S QXX=$O(^TMP($J,LIST,"PMON",FDBSEV,QXX)) Q:QXX=""!($G(MONQ)) S PSOMONQ=0 D
- .F QX=0:0 S QX=$O(^TMP($J,LIST,"PMON",FDBSEV,QXX,QX)) Q:'QX!($G(PSOMONQ)=1)!($G(MONQ)) W !,^TMP($J,LIST,"PMON",FDBSEV,QXX,QX,0) I $Y+3>IOSL D
- ..I $E(IOST)="C",($Y+3)>IOSL S PSOMONQ=$$PAUSE1()
- ..I PSOMONQ=1 W @IOF Q
- ..I PSOMONQ=2 S MONQ=1
- ..W @IOF,!
- Q
- ;
- PAUSE1() ;Allow "^"
- ;Return 0 if X="" ;Return 1 if X="^" ;Return 2 if Not null or "^"
- NEW DIR,DIRUT,DUOUT,X
- W ! K DIR S DIR("A")="Press RETURN to continue, ""^"" to display the next Monograph or ""^^"" to Exit"
- S DIR("?")="Enter ""^"" to go to next Monograph, ""^^"" to exit the Monograph display."
- S DIR(0)="FOU^^K:(X'="""")!(X'[""^"") X"
- D ^DIR
- I X="" Q 0
- I X="^" Q 1
- Q 2
- RDI ;RDI orders
- Q:'$D(^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2)))
- S RXREC=^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2))
- S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,$J("LOCATION: ",20)_$P(RXREC,"^")_" Remote Rx: "_$P(RXREC,"^",5)
- S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,$J("Drug: ",20)_$P(RXREC,"^",3)_" ("_$P(RXREC,"^",4)_")"
- D FSIG(.FSIG)
- S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,$J("SIG: ",20) F I=1:1 Q:'$D(FSIG(I)) W:'$G(PSODUPF) ?20,FSIG(I) I $O(FSIG(I)) W:'$G(PSODUPF) !
- I $G(QTHER) S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,$J("QTY: ",20)_$P(RXREC,"^",8),?40,$J("Days Supply: ",24)_$P(RXREC,"^",7)
- S:$G(PSODUPF) PSODUPC(ZCT)=PSODUPC(ZCT)+1 W:'$G(PSODUPF) !,$J("Last Filled On: ",20)_$P(RXREC,"^",6)
- S ^TMP($J,"PSONRVADD",RXREC,0)=1
- K RXREC,I,FSIG
- Q
- FSIG(FSIG) ;Format sig from remote site ;returned in the FSIG array
- K FSIG N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,I
- F I=0:1 Q:'$D(^TMP($J,LIST,"OUT","REMOTE",$P(ON,";",2),"SIG",I)) S HSIG(I+1)=^(I)
- FSTART S (FVAR,FVAR1)="",II=1
- F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D I $L(FVAR)>50 S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
- .S FVAR1=$P(HSIG(FFF)," ",(CNT))
- .S FLIM=FVAR
- .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
- I $G(FVAR)'="" S FSIG(II)=FVAR
- I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
- FQUIT ;
- Q
- DCOR ;dc duplicate therapy
- Q:'$D(^XUSEC("PSORPH",DUZ))!$G(PSODLQT)
- S MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Therapy"
- S ACT="Duplicate Therapy Discontinued while "_$S('$G(PSONV):"entering",1:"verifying")_" new RX"
- N DCN,DCRD,LST S THERO=0 F I=0:0 S I=$O(^TMP($J,"PSODCOR",I)) Q:'I S THERO=THERO+1
- I THERO=1 D Q
- .K DIR S DIR(0)="Y",THER(1)=^TMP($J,"PSODCOR",1)
- .S DIR("A")="Discontinue "_$S($P(THER(1),"^")="P":"Pending Order "_$P(THER(1),"^",4),1:"Rx #"_$P(^PSRX($P(THER(1),"^",2),0),"^")_" "_$P(THER(1),"^",4))_" Y/N "
- .D ^DIR S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 Q:$G(PSODLQT) K DIR,DIRUT I 'Y K DIR,THER,THERO,X,Y Q
- .S ^TMP("PSORXDC",$J,$P(THER(1),"^",2),0)=$P(THER(1),"^")_"^"_$P(THER(1),"^",2)_"^"_MSG
- .I $P(THER(1),"^")=52 S ^TMP("PSORXDC",$J,$P(THER(1),"^",2),0)=^TMP("PSORXDC",$J,$P(THER(1),"^",2),0)_"^C^"_ACT_"^"_$P(THER(1),"^",3)_"^"_$P(THER(1),"^",4),PSONOOR="D"
- .S $P(^TMP("PSORXDC",$J,$P(THER(1),"^",2),0),"^",10)=1
- .W !! K ^UTILITY($J,"W") S DIWL=1,DIWR=75,DIWF=""
- .S X="Duplicate Therapy "_$S($P(THER(1),"^")="P":"Pending Order ",1:"Rx #"_$P(^PSRX($P(THER(1),"^",2),0),"^"))_" "_$P(THER(1),"^",4)_" will be discontinued after the acceptance of the new order." D ^DIWP
- .F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W !,^UTILITY($J,"W",1,ZX,0)
- .K ^UTILITY($J,"W"),X,DIWL,DIWR,DIWF W ! H 2
- K DIR S DIR(0)="Y",DIR("A")="Discontinue Orders Y/N ",DIR("B")="No" D ^DIR
- S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 Q:$G(PSODLQT)
- I 'Y K DIR,X,Y Q
- K DIR S DIR(0)="LO^1:"_THERO
- F I=1:1:THERO S DIR("A",I)=I_". "_$S($P(^TMP($J,"PSODCOR",I),"^")="P":"Pending Order "_$P(^TMP($J,"PSODCOR",I),"^",4),1:"Rx #"_$P(^PSRX($P(^TMP($J,"PSODCOR",I),"^",2),0),"^")_" "_$P(^TMP($J,"PSODCOR",I),"^",4))
- S DIR("A")="Select Order(s)" D ^DIR S:($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) PSODLQT=1,PSORX("DFLG")=1 Q:$G(PSODLQT) K DIR,DIRUT I 'Y K THER,THERO Q
- S LST=Y(0) F DCRD=1:1:$L(LST,",") Q:$P(LST,",",DCRD)']""!$G(PSODLQT) D
- .S DCN=$P(LST,",",DCRD),THER(DCN)=^TMP($J,"PSODCOR",DCN)
- .S ^TMP("PSORXDC",$J,$P(THER(DCN),"^",2),0)=$P(THER(DCN),"^")_"^"_$P(THER(DCN),"^",2)_"^"_MSG
- .I $P(THER(DCN),"^")=52 S ^TMP("PSORXDC",$J,$P(THER(DCN),"^",2),0)=^TMP("PSORXDC",$J,$P(THER(DCN),"^",2),0)_"^C^"_ACT_"^"_$P(THER(DCN),"^",3)_"^"_$P(THER(DCN),"^",4),PSONOOR="D"
- .S $P(^TMP("PSORXDC",$J,$P(THER(DCN),"^",2),0),"^",10)=1
- .W ! K ^UTILITY($J,"W") S DIWL=1,DIWR=75,DIWF=""
- .S X="Duplicate Therapy "_$S($P(THER(DCN),"^")="P":"Pending Order "_$P(THER(DCN),"^",4),1:"Rx #"_$P(^PSRX($P(THER(DCN),"^",2),0),"^")_" "_$P(THER(DCN),"^",4))_" will be discontinued after the acceptance of the new order." D ^DIWP
- .F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX W !,^UTILITY($J,"W",1,ZX,0)
- .K ^UTILITY($J,"W"),X,DIWL,DIWR,DIWF H 2
- W ! K X,Y,THER,THERO,MSG,ACT,I,DIR
- Q
- FPMON ;displays instruction and/or comments
- S PMON=PMON+1,MG=^TMP($J,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",QX,0)
- I MG="" S ^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)="",PMON=PMON+1 Q
- I $L(MG)>70 F SG=1:1:$L(MG," ") S:$L(($G(^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)))_" "_$P(MG," ",SG))>80 PMON=PMON+1 S ^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=$G(^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0))_$P(MG," ",SG)_" "
- E S PMON=PMON+1,^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=$G(^TMP($J,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0))_MG
- K MG,SG
- Q
- VAGEN(PSODD) ;Return the VA GENERIC name
- ;PSODD - IEN (file #50)
- N PSOIEN I '+$G(PSODD) Q ""
- S PSOIEN=+$G(^PSDRUG(PSODD,"ND")) D ZERO^PSN50P6(PSOIEN,,,,"PSOVAG")
- S PSOVAG=$G(^TMP($J,"PSOVAG",PSOIEN,.01)) K ^TMP($J,"PSOVAG")
- Q PSOVAG
- INST ;displays instruction and/or comments
- S INST=0 F S INST=$O(^PS(52.41,RXREC,TY,INST)) Q:'INST S MIG=^PS(52.41,RXREC,TY,INST,0) D
- .W !,$S(TY=2:" "_$S($$ERXIEN^PSOERXUT(RXREC_"P"):"eRx",1:" ")_" Instructions: ",TY=3:" Provider Comments: ",1:"")
- .F SG=1:1:$L(MIG," ") D HD^PSODDPR2() Q:$G(PSODLQT) W:$X+$L($P(MIG," ",SG)_" ")>IOM @$S(TY=3:"!?14",1:"!?19") W $P(MIG," ",SG)_" "
- K INST,TY,MIG,SG
- Q
- CLASSES ;display therapeutic duplications classes (called from PSODDPR5 too)
- I '$G(PSODUPF) D
- .I '$G(PSODUPCT)&('$G(PSODUPC("CLASS"))) D HD^PSODDPR2() Q
- .I ($G(PSODUPCT)+PSODUPC("CLASS"))>22 D HD^PSODDPR2(15) S PSODUPCT=0
- Q:$G(PSODLQT)
- K ^UTILITY($J,"W") S DIWL=1,DIWR=75,DIWF="",ZCT=0 S:$G(PSODUPF) PSODUPC("CLASS")=PSODUPC("CLASS")+1 W:'$G(PSODUPF) !
- S X="Class(es) Involved in Therapeutic Duplication(s): " D ^DIWP
- S (ZCT,ZZCT,ZZZCT)=0 F S ZZCT=$O(^TMP($J,LIST,"OUT","THERAPY",ZZCT)) Q:'ZZCT S ZCT=0 F S ZCT=$O(^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT)) Q:'ZCT D
- . S X=^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS")
- . S X=^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS")_$S($O(^TMP($J,LIST,"OUT","THERAPY",ZZCT))!($O(^TMP($J,LIST,"OUT","THERAPY",ZZCT,ZCT))):", ",1:" ")
- . D ^DIWP
- F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX S:$G(PSODUPF) PSODUPC("CLASS")=PSODUPC("CLASS")+1 W:'$G(PSODUPF) !,^UTILITY($J,"W",1,ZX,0)
- K ^UTILITY($J,"W"),X,CLASS,DIWL,DIWR,DIWF,ZX,DRG,ZCT,ZZCT,ZZZCT
- S:$G(PSODUPF) PSODUPC("CLASS")=PSODUPC("CLASS")+1 W:'$G(PSODUPF) !,PSONULN1,!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODDPR3 12274 printed Feb 18, 2025@23:52:53 Page 2
- PSODDPR3 ;BIR/SAB - display NVA enhanced order checks ;10/04/06 3:38pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**251,375,379,372,651**;DEC 1997;Build 30
- +2 ;Reference ^PSDRUG supported by DBIA 221
- +3 ;Reference ^PS(55 supported by DBIA 2228
- +4 ;Reference ^PS(50.7 is supported by DBIA 2223
- +5 ;Reference ^PS(50.606 supported by DBIA 2174
- NVA SET DUPRX0=^PS(55,PSODFN,"NVA",$PIECE(ON,";",2),0)
- NEW NVAQ
- +1 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !
- IF '$PIECE(DUPRX0,"^",2)
- if '$GET(PSODUPF)
- WRITE $JUSTIFY("Non-VA Med: ",20)_$PIECE(^PS(50.7,$PIECE(DUPRX0,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
- +2 IF '$TEST
- if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE $JUSTIFY("Non-VA Med: ",20)_$PIECE(^PSDRUG($PIECE(DUPRX0,"^",2),0),"^")
- +3 ;W " (Active)"
- +4 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !,$JUSTIFY("Dosage: ",20)_$SELECT($PIECE(DUPRX0,"^",3)]"":$PIECE(DUPRX0,"^",3),1:"<NOT ENTERED>"),$JUSTIFY("Schedule: ",20)_$SELECT($PIECE(DUPRX0,"^",5)]"":$PIECE(DUPRX0,"^",5),1:"<NOT ENTERED>")
- +5 KILL DSC,DSPL,CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG
- +6 KILL LST,THER,THERO,^UTILITY($JOB),DGI,SER,SEV,SERS,BSIG,I,NODDERR,NODTERR,PDRG,DRGI,IZ
- +7 KILL ^UTILITY($JOB,"W"),X,ZX,DIWL,DIWR,DIWF
- +8 QUIT
- MON ;print monograph
- +1 if $GET(PSODLQT)
- QUIT
- +2 NEW MONQ,DRGINFO,PVAGDRG,PVAGDRG,VAGDRG,MDRGCNT,MONSEV,PSOMON1,MONTITLE,FDBSEV,SMONTI,MONQ
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Display Interaction Monograph"
- SET DIR("B")="No"
- DO ^DIR
- +3 if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
- SET PSODLQT=1
- SET PSORX("DFLG")=1
- if $GET(PSODLQT)
- WRITE !,PSONULN,!
- KILL DIR,DTOUT,DUOUT,DIRUT
- if 'Y!($GET(PSODLQT))
- QUIT
- +4 ;ADD OUTPUT DEVICE
- +5 KILL IOP,%ZIS,POP
- SET %ZIS="QM"
- DO ^%ZIS
- +6 IF POP
- WRITE !,"NOTHING PRINTED"
- QUIT
- +7 IF '$TEST
- WRITE !
- +8 IF $DATA(IO("Q"))
- Begin DoDot:1
- +9 SET ZTRTN="QUE^PSODDPR3"
- SET ZTDESC="Monograph Report of Drug Interactions"
- SET ZTSAVE("PSONULN")=""
- SET ZTSAVE("SEV")=""
- SET ZTSAVE("LIST")=""
- +10 SET ZTSAVE("^TMP($J,LIST,""OUT"",""DRUGDRUG"",SV,DRG,ON,")=""
- SET ZTSAVE("ON")=""
- SET ZTSAVE("DRG")=""
- SET ZTSAVE("CT")=""
- SET ZTSAVE("PDRG")=""
- +11 SET ZTSAVE("^TMP($J,""OUT"",""REMOTE"",")=""
- SET ZTSAVE("SV")=""
- +12 DO ^%ZTLOAD
- DO ^%ZISC
- WRITE !,"Monograph Queued to Print!",!
- +13 if $DATA(ZTQUEUED)
- SET ZTREQ="Q"
- End DoDot:1
- QUIT
- +14 DO QUE
- DO ^%ZISC
- +15 IF $EXTRACT(IOST)="C"
- IF '$GET(PSOMONQ)
- KILL DIR
- SET DIR(0)="E"
- SET DIR("?")="Press Return to continue"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- WRITE @IOF
- if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
- SET PSODLQT=1
- SET PSORX("DFLG")=1
- KILL DIR,DTOUT,DUOUT,DIRUT
- +16 KILL DIR,DTOUT,DUOUT,^UTILITY($JOB),DIWL,DIWR,DIWF,X,QX,PMON,RDI,^TMP($JOB,LIST,"PMON"),RMRX,PSOMON1,PSOMONQ,MONQ,FDBSEV,MONTITLE,SMONTI
- +17 QUIT
- +18 ;
- QUE SET (CT,PMON,MDRGCNT)=0
- KILL ^TMP($JOB,LIST,"PMON")
- +1 USE IO
- +2 ;sort to attain an array of FDBSEV by drug and monograph title. Note that the PMON array is already sorted by Vista Severity
- +3 FOR
- SET CT=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT))
- if 'CT
- QUIT
- Begin DoDot:1
- +4 IF $DATA(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",5,0))
- SET MONSEV=""
- SET MONSEV=^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",5,0)
- Begin DoDot:2
- +5 SET FDBSEV=$PIECE($PIECE(MONSEV,"SEVERITY LEVEL: ",2),"-",1)
- SET FDBSEV=$TRANSLATE(FDBSEV," ","")
- if '$GET(FDBSEV)
- SET FDBSEV=999999999
- +6 SET MONTITLE=""
- SET MONTITLE=$GET(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",3,0))
- SET MONTITLE=$PIECE(MONTITLE,"MONOGRAPH TITLE: ",2)
- +7 if MONTITLE=""
- SET MONTITLE="Zz No title given"
- +8 SET PSOMON1(DRG,MONTITLE,FDBSEV)=""
- End DoDot:2
- End DoDot:1
- +9 if $GET(PSODLQT)
- QUIT
- +10 ;sort "PMON" nodes by drug and FDB severity then print monograph; MDRGCNT = monograph drug count - sequential number counting monographs per drug. If multiple monographs fro same drug allows display of each.
- +11 ;; PMON = counter of # of lines in the monograph to be displayed; FDBSEV = FDB severity for each monograph within the Vista severity
- +12 FOR
- SET CT=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT))
- if 'CT!$GET(PSODLQT)
- QUIT
- Begin DoDot:1
- +13 SET DRGINFO=^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT)
- SET PDRGIEN=$PIECE(DRGINFO,"^",2)
- SET DRGIEN=$PIECE(DRGINFO,"^",3)
- +14 SET PVAGDRG=$$GET1^DIQ(50,PDRGIEN,20,"E")
- SET VAGDRG=$$GET1^DIQ(50,DRGIEN,20,"E")
- SET MDRGCNT=MDRGCNT+1
- +15 IF PVAGDRG=""
- SET PVAGDRG=$PIECE(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT),"^",4)
- +16 IF VAGDRG=""
- SET VAGDRG=DRG
- +17 SET SMONTI=$GET(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",3,0))
- SET SMONTI=$PIECE(SMONTI,"MONOGRAPH TITLE: ",2)
- +18 IF $DATA(PSOMON1(DRG,SMONTI))
- SET FDBSEV=""
- SET FDBSEV=$ORDER(PSOMON1(DRG,SMONTI,FDBSEV))
- +19 SET PMON=PMON+1
- SET ^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=PSONULN
- +20 SET PMON=PMON+1
- SET ^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)="Professional Monograph"
- SET PMON=PMON+1
- +21 SET ^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)="Drug Interaction with "_PVAGDRG_" and "_VAGDRG
- SET PMON=PMON+1
- SET ^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=""
- +22 FOR QX=0:0
- SET QX=$ORDER(^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",QX))
- if 'QX
- QUIT
- DO FPMON
- End DoDot:1
- SET PMON=PMON+1
- SET ^TMP($JOB,LIST,"PMON",PMON,0)=""
- +23 if '$ORDER(^TMP($JOB,LIST,"PMON",0))!$GET(PSODLQT)
- QUIT
- +24 KILL DIR,DTOUT,DUOUT,MONQ
- USE IO
- WRITE @IOF
- +25 IF $PIECE(ON,";")="R"
- SET RMRX=$PIECE(^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2)),"^",5)
- +26 ;display monograph detailed information
- +27 FOR FDBSEV=0:0
- SET FDBSEV=$ORDER(^TMP($JOB,LIST,"PMON",FDBSEV))
- if FDBSEV=""!($GET(MONQ))
- QUIT
- FOR QXX=0:0
- SET QXX=$ORDER(^TMP($JOB,LIST,"PMON",FDBSEV,QXX))
- if QXX=""!($GET(MONQ))
- QUIT
- SET PSOMONQ=0
- Begin DoDot:1
- +28 FOR QX=0:0
- SET QX=$ORDER(^TMP($JOB,LIST,"PMON",FDBSEV,QXX,QX))
- if 'QX!($GET(PSOMONQ)=1)!($GET(MONQ))
- QUIT
- WRITE !,^TMP($JOB,LIST,"PMON",FDBSEV,QXX,QX,0)
- IF $Y+3>IOSL
- Begin DoDot:2
- +29 IF $EXTRACT(IOST)="C"
- IF ($Y+3)>IOSL
- SET PSOMONQ=$$PAUSE1()
- +30 IF PSOMONQ=1
- WRITE @IOF
- QUIT
- +31 IF PSOMONQ=2
- SET MONQ=1
- +32 WRITE @IOF,!
- End DoDot:2
- End DoDot:1
- +33 QUIT
- +34 ;
- PAUSE1() ;Allow "^"
- +1 ;Return 0 if X="" ;Return 1 if X="^" ;Return 2 if Not null or "^"
- +2 NEW DIR,DIRUT,DUOUT,X
- +3 WRITE !
- KILL DIR
- SET DIR("A")="Press RETURN to continue, ""^"" to display the next Monograph or ""^^"" to Exit"
- +4 SET DIR("?")="Enter ""^"" to go to next Monograph, ""^^"" to exit the Monograph display."
- +5 SET DIR(0)="FOU^^K:(X'="""")!(X'[""^"") X"
- +6 DO ^DIR
- +7 IF X=""
- QUIT 0
- +8 IF X="^"
- QUIT 1
- +9 QUIT 2
- RDI ;RDI orders
- +1 if '$DATA(^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2)))
- QUIT
- +2 SET RXREC=^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2))
- +3 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !,$JUSTIFY("LOCATION: ",20)_$PIECE(RXREC,"^")_" Remote Rx: "_$PIECE(RXREC,"^",5)
- +4 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !,$JUSTIFY("Drug: ",20)_$PIECE(RXREC,"^",3)_" ("_$PIECE(RXREC,"^",4)_")"
- +5 DO FSIG(.FSIG)
- +6 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !,$JUSTIFY("SIG: ",20)
- FOR I=1:1
- if '$DATA(FSIG(I))
- QUIT
- if '$GET(PSODUPF)
- WRITE ?20,FSIG(I)
- IF $ORDER(FSIG(I))
- if '$GET(PSODUPF)
- WRITE !
- +7 IF $GET(QTHER)
- if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !,$JUSTIFY("QTY: ",20)_$PIECE(RXREC,"^",8),?40,$JUSTIFY("Days Supply: ",24)_$PIECE(RXREC,"^",7)
- +8 if $GET(PSODUPF)
- SET PSODUPC(ZCT)=PSODUPC(ZCT)+1
- if '$GET(PSODUPF)
- WRITE !,$JUSTIFY("Last Filled On: ",20)_$PIECE(RXREC,"^",6)
- +9 SET ^TMP($JOB,"PSONRVADD",RXREC,0)=1
- +10 KILL RXREC,I,FSIG
- +11 QUIT
- FSIG(FSIG) ;Format sig from remote site ;returned in the FSIG array
- +1 KILL FSIG
- NEW FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,I
- +2 FOR I=0:1
- if '$DATA(^TMP($JOB,LIST,"OUT","REMOTE",$PIECE(ON,";",2),"SIG",I))
- QUIT
- SET HSIG(I+1)=^(I)
- FSTART SET (FVAR,FVAR1)=""
- SET II=1
- +1 FOR FFF=0:0
- SET FFF=$ORDER(HSIG(FFF))
- if 'FFF
- QUIT
- SET CNT=0
- FOR NNN=1:1:$LENGTH(HSIG(FFF))
- IF $EXTRACT(HSIG(FFF),NNN)=" "!($LENGTH(HSIG(FFF))=NNN)
- SET CNT=CNT+1
- Begin DoDot:1
- +2 SET FVAR1=$PIECE(HSIG(FFF)," ",(CNT))
- +3 SET FLIM=FVAR
- +4 SET FVAR=$SELECT(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
- End DoDot:1
- IF $LENGTH(FVAR)>50
- SET FSIG(II)=FLIM_" "
- SET II=II+1
- SET FVAR=FVAR1
- +5 IF $GET(FVAR)'=""
- SET FSIG(II)=FVAR
- +6 IF $GET(FSIG(1))=""!($GET(FSIG(1))=" ")
- SET FSIG(1)=$GET(FSIG(2))
- KILL FSIG(2)
- FQUIT ;
- +1 QUIT
- DCOR ;dc duplicate therapy
- +1 if '$DATA(^XUSEC("PSORPH",DUZ))!$GET(PSODLQT)
- QUIT
- +2 SET MSG="Discontinued During "_$SELECT('$GET(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Therapy"
- +3 SET ACT="Duplicate Therapy Discontinued while "_$SELECT('$GET(PSONV):"entering",1:"verifying")_" new RX"
- +4 NEW DCN,DCRD,LST
- SET THERO=0
- FOR I=0:0
- SET I=$ORDER(^TMP($JOB,"PSODCOR",I))
- if 'I
- QUIT
- SET THERO=THERO+1
- +5 IF THERO=1
- Begin DoDot:1
- +6 KILL DIR
- SET DIR(0)="Y"
- SET THER(1)=^TMP($JOB,"PSODCOR",1)
- +7 SET DIR("A")="Discontinue "_$SELECT($PIECE(THER(1),"^")="P":"Pending Order "_$PIECE(THER(1),"^",4),1:"Rx #"_$PIECE(^PSRX($PIECE(THER(1),"^",2),0),"^")_" "_$PIECE(THER(1),"^",4))_" Y/N "
- +8 DO ^DIR
- if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
- SET PSODLQT=1
- SET PSORX("DFLG")=1
- if $GET(PSODLQT)
- QUIT
- KILL DIR,DIRUT
- IF 'Y
- KILL DIR,THER,THERO,X,Y
- QUIT
- +9 SET ^TMP("PSORXDC",$JOB,$PIECE(THER(1),"^",2),0)=$PIECE(THER(1),"^")_"^"_$PIECE(THER(1),"^",2)_"^"_MSG
- +10 IF $PIECE(THER(1),"^")=52
- SET ^TMP("PSORXDC",$JOB,$PIECE(THER(1),"^",2),0)=^TMP("PSORXDC",$JOB,$PIECE(THER(1),"^",2),0)_"^C^"_ACT_"^"_$PIECE(THER(1),"^",3)_"^"_$PIECE(THER(1),"^",4)
- SET PSONOOR="D"
- +11 SET $PIECE(^TMP("PSORXDC",$JOB,$PIECE(THER(1),"^",2),0),"^",10)=1
- +12 WRITE !!
- KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=75
- SET DIWF=""
- +13 SET X="Duplicate Therapy "_$SELECT($PIECE(THER(1),"^")="P":"Pending Order ",1:"Rx #"_$PIECE(^PSRX($PIECE(THER(1),"^",2),0),"^"))_" "_$PIECE(THER(1),"^",4)_" will be discontinued after the acceptance of the new order."
- DO ^DIWP
- +14 FOR ZX=0:0
- SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
- if 'ZX
- QUIT
- WRITE !,^UTILITY($JOB,"W",1,ZX,0)
- +15 KILL ^UTILITY($JOB,"W"),X,DIWL,DIWR,DIWF
- WRITE !
- HANG 2
- End DoDot:1
- QUIT
- +16 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Discontinue Orders Y/N "
- SET DIR("B")="No"
- DO ^DIR
- +17 if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
- SET PSODLQT=1
- SET PSORX("DFLG")=1
- if $GET(PSODLQT)
- QUIT
- +18 IF 'Y
- KILL DIR,X,Y
- QUIT
- +19 KILL DIR
- SET DIR(0)="LO^1:"_THERO
- +20 FOR I=1:1:THERO
- SET DIR("A",I)=I_". "_$SELECT($PIECE(^TMP($JOB,"PSODCOR",I),"^")="P":"Pending Order "_$PIECE(^TMP($JOB,"PSODCOR",I),"^",4),1:"Rx #"_$PIECE(^PSRX($PIECE(^TMP($JOB,"PSODCOR",I),"^",2),0),"^")_" "_$PIECE(^TMP($JOB,"PSODCOR",I),"^",4))
- +21 SET DIR("A")="Select Order(s)"
- DO ^DIR
- if ($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
- SET PSODLQT=1
- SET PSORX("DFLG")=1
- if $GET(PSODLQT)
- QUIT
- KILL DIR,DIRUT
- IF 'Y
- KILL THER,THERO
- QUIT
- +22 SET LST=Y(0)
- FOR DCRD=1:1:$LENGTH(LST,",")
- if $PIECE(LST,",",DCRD)']""!$GET(PSODLQT)
- QUIT
- Begin DoDot:1
- +23 SET DCN=$PIECE(LST,",",DCRD)
- SET THER(DCN)=^TMP($JOB,"PSODCOR",DCN)
- +24 SET ^TMP("PSORXDC",$JOB,$PIECE(THER(DCN),"^",2),0)=$PIECE(THER(DCN),"^")_"^"_$PIECE(THER(DCN),"^",2)_"^"_MSG
- +25 IF $PIECE(THER(DCN),"^")=52
- SET ^TMP("PSORXDC",$JOB,$PIECE(THER(DCN),"^",2),0)=^TMP("PSORXDC",$JOB,$PIECE(THER(DCN),"^",2),0)_"^C^"_ACT_"^"_$PIECE(THER(DCN),"^",3)_"^"_$PIECE(THER(DCN),"^",4)
- SET PSONOOR="D"
- +26 SET $PIECE(^TMP("PSORXDC",$JOB,$PIECE(THER(DCN),"^",2),0),"^",10)=1
- +27 WRITE !
- KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=75
- SET DIWF=""
- +28 SET X="Duplicate Therapy "_$SELECT($PIECE(THER(DCN),"^")="P":"Pending Order "_$PIECE(THER(DCN),"^",4),1:"Rx #"_$PIECE(^PSRX($PIECE(THER(DCN),"^",2),0),"^")_" "_$PIECE(THER(DCN),"^",4))_" will be discontinued after the acceptance of the
- new order."
- DO ^DIWP
- +29 FOR ZX=0:0
- SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
- if 'ZX
- QUIT
- WRITE !,^UTILITY($JOB,"W",1,ZX,0)
- +30 KILL ^UTILITY($JOB,"W"),X,DIWL,DIWR,DIWF
- HANG 2
- End DoDot:1
- +31 WRITE !
- KILL X,Y,THER,THERO,MSG,ACT,I,DIR
- +32 QUIT
- FPMON ;displays instruction and/or comments
- +1 SET PMON=PMON+1
- SET MG=^TMP($JOB,LIST,"OUT","DRUGDRUG",SV,DRG,ON,CT,"PMON",QX,0)
- +2 IF MG=""
- SET ^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=""
- SET PMON=PMON+1
- QUIT
- +3 IF $LENGTH(MG)>70
- FOR SG=1:1:$LENGTH(MG," ")
- if $LENGTH(($GET(^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)))_" "_$PIECE(MG," ",SG))>80
- SET PMON=PMON+1
- SET ^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=$GET(^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0))_$PIECE(MG," ",SG)_" "
- +4 IF '$TEST
- SET PMON=PMON+1
- SET ^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0)=$GET(^TMP($JOB,LIST,"PMON",FDBSEV,MDRGCNT,PMON,0))_MG
- +5 KILL MG,SG
- +6 QUIT
- VAGEN(PSODD) ;Return the VA GENERIC name
- +1 ;PSODD - IEN (file #50)
- +2 NEW PSOIEN
- IF '+$GET(PSODD)
- QUIT ""
- +3 SET PSOIEN=+$GET(^PSDRUG(PSODD,"ND"))
- DO ZERO^PSN50P6(PSOIEN,,,,"PSOVAG")
- +4 SET PSOVAG=$GET(^TMP($JOB,"PSOVAG",PSOIEN,.01))
- KILL ^TMP($JOB,"PSOVAG")
- +5 QUIT PSOVAG
- INST ;displays instruction and/or comments
- +1 SET INST=0
- FOR
- SET INST=$ORDER(^PS(52.41,RXREC,TY,INST))
- if 'INST
- QUIT
- SET MIG=^PS(52.41,RXREC,TY,INST,0)
- Begin DoDot:1
- +2 WRITE !,$SELECT(TY=2:" "_$SELECT($$ERXIEN^PSOERXUT(RXREC_"P"):"eRx",1:" ")_" Instructions: ",TY=3:" Provider Comments: ",1:"")
- +3 FOR SG=1:1:$LENGTH(MIG," ")
- DO HD^PSODDPR2()
- if $GET(PSODLQT)
- QUIT
- if $X+$LENGTH($PIECE(MIG," ",SG)_" ")>IOM
- WRITE @$SELECT(TY=3:"!?14",1:"!?19")
- WRITE $PIECE(MIG," ",SG)_" "
- End DoDot:1
- +4 KILL INST,TY,MIG,SG
- +5 QUIT
- CLASSES ;display therapeutic duplications classes (called from PSODDPR5 too)
- +1 IF '$GET(PSODUPF)
- Begin DoDot:1
- +2 IF '$GET(PSODUPCT)&('$GET(PSODUPC("CLASS")))
- DO HD^PSODDPR2()
- QUIT
- +3 IF ($GET(PSODUPCT)+PSODUPC("CLASS"))>22
- DO HD^PSODDPR2(15)
- SET PSODUPCT=0
- End DoDot:1
- +4 if $GET(PSODLQT)
- QUIT
- +5 KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=75
- SET DIWF=""
- SET ZCT=0
- if $GET(PSODUPF)
- SET PSODUPC("CLASS")=PSODUPC("CLASS")+1
- if '$GET(PSODUPF)
- WRITE !
- +6 SET X="Class(es) Involved in Therapeutic Duplication(s): "
- DO ^DIWP
- +7 SET (ZCT,ZZCT,ZZZCT)=0
- FOR
- SET ZZCT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT))
- if 'ZZCT
- QUIT
- SET ZCT=0
- FOR
- SET ZCT=$ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT,ZCT))
- if 'ZCT
- QUIT
- Begin DoDot:1
- +8 SET X=^TMP($JOB,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS")
- +9 SET X=^TMP($JOB,LIST,"OUT","THERAPY",ZZCT,ZCT,"CLASS")_$SELECT($ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT))!($ORDER(^TMP($JOB,LIST,"OUT","THERAPY",ZZCT,ZCT))):", ",1:" ")
- +10 DO ^DIWP
- End DoDot:1
- +11 FOR ZX=0:0
- SET ZX=$ORDER(^UTILITY($JOB,"W",1,ZX))
- if 'ZX
- QUIT
- if $GET(PSODUPF)
- SET PSODUPC("CLASS")=PSODUPC("CLASS")+1
- if '$GET(PSODUPF)
- WRITE !,^UTILITY($JOB,"W",1,ZX,0)
- +12 KILL ^UTILITY($JOB,"W"),X,CLASS,DIWL,DIWR,DIWF,ZX,DRG,ZCT,ZZCT,ZZZCT
- +13 if $GET(PSODUPF)
- SET PSODUPC("CLASS")=PSODUPC("CLASS")+1
- if '$GET(PSODUPF)
- WRITE !,PSONULN1,!
- +14 QUIT