PSOSULOG ;BHAM ISC/RTR-Log of prescriptions on suspense by day ;29-May-2012 15:15;PLS
;;7.0;OUTPATIENT PHARMACY;**18,1008,264;1015**;Build 62;Build 19
;Modified - IHS/MSC/PLS - 04/30/2009 - Changed references of SSN to HRN
I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) D WARN^PSOSUDCN Q
K ^TMP($J,"PSOSPLOG") N BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
LOG ;IHS/MSC/PLS - 04/30/2009
;W ! K DIR S DIR("A")="Sort by Patient Name or SSN",DIR(0)="SB^P:PATIENT NAME;S:SOCIAL SECURITY NUMBER",DIR("B")="PATIENT NAME"
W ! K DIR S DIR("A")="Sort by Patient Name or HRN",DIR(0)="SB^P:PATIENT NAME;H:HEALTH RECORD NUMBER",DIR("B")="PATIENT NAME"
;S DIR("?")="Enter 'P' to sort by patient name, 'S' to sort by SSN, enter '^' to exit."
S DIR("?")="Enter 'P' to sort by patient name, 'H' to sort by HRN, enter '^' to exit."
D ^DIR K DIR D:$D(DIRUT) MESS G:$D(DIRUT) EXIT S PSORT=Y
DATE W ! K %DT S %DT="AEX",%DT("A")="Start Date: " D ^%DT K %DT G:Y=-1&(X'["^") DATE I X["^"!($D(DTOUT)) D MESS G EXIT
EDATE W ! S BDATE=$E(Y,1,7) S %DT(0)=BDATE,%DT="AEX",%DT("A")="End Date: " D ^%DT K %DT G:Y=-1&(X'["^") EDATE I X["^"!($D(DTOUT)) D MESS G EXIT
S EDATE=$E(Y,1,7) W !
W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to see only those Rx's that have NOT yet been printed" D ^DIR K DIR D:$D(DIRUT) MESS G:Y["^"!($D(DIRUT)) EXIT S PSPRINT=$S(Y:1,1:0)
S PSOCNT=0 F PII=0:0 S PII=$O(^PS(59,PII)) Q:'PII S PSOCNT=PSOCNT+1
I PSOCNT=1 G SKIP
W !!?3,"You are logged in under the "_$P($G(^PS(59,+$G(PSOSITE),0)),"^")_" division.",!
K DIR S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Print only those Rx's suspended for this division",DIR("?")="Enter 'Yes' to print only those Rx's for this division, enter 'No' to print Rx's suspended for all divisions."
D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
S PSUSDIV=Y
SKIP ;
I '$G(PSXSYS) G SKIPC
K DIR W ! S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want suspended CMOP Rx's included in this report" D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
I $G(Y) S PSOSCMOP=1
SKIPC ;
W ! K DIR S DIR("A")="Do you want this report to print in 80 or 132 column format: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80" D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
W ! S PSORMZ=$S(Y=1:1,1:0)
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I POP D MESS G EXIT
I $D(IO("Q")) S ZTRTN="REP^PSOSULOG",ZTDESC="Report is suspended Rx's" D G EXIT
.F GG="PSORMZ","PSOSITE","PSOPAR","PSORT","BDATE","EDATE","PSPRINT","PSUSDIV","PSOSCMOP" S:$D(@GG) ZTSAVE(GG)=""
.D ^%ZTLOAD W !,"Task queued to print"
G REP
EXIT ;
K ^TMP($J,"PSOSPLOG") S:$D(ZTQUEUED) ZTREQ="@"
K BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOBAD,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORMZ,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
Q
MESS W !!,"No report printed!",!! Q
REP ;
K ^TMP($J,"PSOSPLOG")
U IO S $P(LINE,"-",$S($G(PSORMZ):130,1:79))=""
N PHRN,SUSDIV,DIVINS ;IHS/MSC/PLS - 04/30/09
S BDATE=BDATE-.0001,QFLAG=0,PAGE=1
F ZZ=BDATE:0 S ZZ=$O(^PS(52.5,"C",ZZ)) Q:'ZZ!(ZZ>EDATE) F SIN=0:0 S SIN=$O(^PS(52.5,"C",ZZ,SIN)) Q:'SIN D
.Q:'$P($G(^PS(52.5,SIN,0)),"^",3)
.I $G(PSPRINT),$G(^PS(52.5,SIN,"P")) Q
.I '$G(PSOSCMOP),$P($G(^PS(52.5,SIN,0)),"^",7)'="" Q
.I $G(PSUSDIV),$G(PSOSITE)'=$P($G(^PS(52.5,SIN,0)),"^",6) Q
.S PAT=+$P($G(^PS(52.5,SIN,0)),"^",3) I $P($G(^DPT(PAT,0)),"^")="" Q
.;IHS/MSC/PLS - 04/30/09
.;I $P($G(^DPT(PAT,0)),"^",9)="",PSORT="S" Q
.S SUSDIV=$P($G(^PS(52.5,SIN,0)),U,6),DIVINS=+$$GET1^DIQ(59,SUSDIV,100,"I")
.S PHRN=$$HRN^AUPNPAT(PAT,DIVINS)
.I PSORT="H",PHRN<1 Q
.;S ^TMP($J,"PSOSPLOG",ZZ,$S(PSORT="P":$P(^DPT(PAT,0),"^"),1:$P(^DPT(PAT,0),"^",9)),SIN)=SIN
.S ^TMP($J,"PSOSPLOG",ZZ,$S(PSORT="P":$P(^DPT(PAT,0),"^"),1:PHRN),SIN)=SIN
I $G(PSORMZ) G BIG
I '$D(^TMP($J,"PSOSPLOG")) D HEAD W !!,"NO RECORDS TO PRINT",! D:$E(IOST)="C" D ^%ZISC G EXIT
.K DIR S DIR(0)="E" D ^DIR K DIR
S HPAT="",HDAT=""
F PSODATE=0:0 S PSODATE=$O(^TMP($J,"PSOSPLOG",PSODATE)) Q:'PSODATE!($G(QFLAG)) S (Y,PDAT)=PSODATE D DD^%DT S PSODATEX=Y D HEAD S PAT="" F S PAT=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT)) Q:PAT=""!($G(QFLAG)) D
.F SINRX=0:0 S SINRX=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT,SINRX)) Q:'SINRX!($G(QFLAG)) D
..S NODE=$G(^PS(52.5,SINRX,0)),PATPTR=+$P(NODE,"^",3)
..I 'PATPTR Q
..S PATNAME=$P($G(^DPT(PATPTR,0)),"^") Q:PATNAME=""
..I $G(PSPRINT),$G(^PS(52.5,SINRX,"P")) Q
..I $G(PSUSDIV),$G(PSOSITE)'=$P(NODE,"^",6) Q
..I PAT'=HPAT!(HDAT'=PDAT) W !!?9,"Patient Name: "_$G(PATNAME) S HPAT=PAT,PDAT=HDAT
..D:($Y+4)>IOSL HEAD Q:$G(QFLAG)
..S PSOINRX=+$P($G(NODE),"^")
..W !,$P($G(^PSRX(+$G(NODE),0)),"^")
..W ?13,$P($G(^PSDRUG(+$P($G(^PSRX(PSOINRX,0)),"^",6),0)),"^")
..K PSOMW D
...I $P(NODE,"^",5) S PSOMW=$P($G(^PSRX(+$G(NODE),"P",$P(NODE,"^",5),0)),"^",2) Q
...I $P(NODE,"^",13)!($O(^PSRX(+$G(NODE),1,0))) D Q
....I $P(NODE,"^",13) S PSOMW=$P($G(^PSRX(+$G(NODE),1,$P(NODE,"^",13),0)),"^",2) Q
....F PP=0:0 S PP=$O(^PSRX(+$G(NODE),1,PP)) Q:'PP S PSOMW=$P($G(^PSRX(+$G(NODE),1,PP,0)),"^",2)
...S PSOMW=$P($G(^PSRX(+$G(NODE),0)),"^",11)
..W ?54,$G(PSOMW)
..S PSOPRINT=$S($G(^PS(52.5,SINRX,"P")):"YES",1:"NO")
..W ?56,PSOPRINT
..I PSOPRINT="NO" S PSOBAD="" D CHKBAD I PSOBAD'="" W ?62,PSOBAD
..I $G(PSOSCMOP),$P(NODE,"^",7)'="" D
...W ?64,$S($P(NODE,"^",7)="Q":"QUEUED/TRANS",$P(NODE,"^",7)="X":"TRANS/COMPLETE",$P(NODE,"^",7)="L":"LOADING/TRANS",$P(NODE,"^",7)="P":"PRINTED/LOCAL",1:"")
I $E(IOST)'="P",'$G(QFLAG) W ! K DIR S DIR(0)="E" D ^DIR K DIR
W !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
W !,"** END OF REPORT **"
D ^%ZISC G EXIT
HEAD ;
I $E(IOST)'="P",PAGE K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S QFLAG=1 Q
W @IOF W !?22,"RX SUSPENSE LIST "_$S($G(PSODATEX)'="":"FOR ",1:"")_$G(PSODATEX) W ?68,"PAGE: ",$G(PAGE) W !,"RX #",?13,"DRUG",?53,"MW",?56,"PRNT B/D/F",?66,$S($G(PSOSCMOP):"CMOP STATUS",1:"") W !,LINE S PAGE=PAGE+1
Q
BIG ;
N PSOPRINT
I '$D(^TMP($J,"PSOSPLOG")) D HEADB W !!,"NO RECORDS TO PRINT",! D:$E(IOST)="C" D ^%ZISC G EXIT
.K DIR S DIR(0)="E" D ^DIR K DIR
F PSODATE=0:0 S PSODATE=$O(^TMP($J,"PSOSPLOG",PSODATE)) Q:'PSODATE!($G(QFLAG)) S Y=PSODATE D DD^%DT S PSODATEX=Y D:PAGE=1 HEADB D HEADND S PAT="" F S PAT=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT)) Q:PAT=""!($G(QFLAG)) D
.F SINRX=0:0 S SINRX=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT,SINRX)) Q:'SINRX!($G(QFLAG)) D
..S NODE=$G(^PS(52.5,SINRX,0)),PATPTR=+$P(NODE,"^",3)
..I 'PATPTR Q
..S PATNAME=$P($G(^DPT(PATPTR,0)),"^") Q:PATNAME=""
..I $G(PSPRINT),$G(^PS(52.5,SINRX,"P")) Q
..I $G(PSUSDIV),$G(PSOSITE)'=$P(NODE,"^",6) Q
..D:($Y+4)>IOSL HEADB Q:$G(QFLAG)
..S PSOINRX=+$P($G(NODE),"^")
..W !,$P($G(^PSRX(+$G(NODE),0)),"^")
..W ?13,$G(PATNAME)
..W ?45,$P($G(^PSDRUG(+$P($G(^PSRX(PSOINRX,0)),"^",6),0)),"^")
..K PSOMW D
...I $P(NODE,"^",5) S PSOMW=$P($G(^PSRX(+$G(NODE),"P",$P(NODE,"^",5),0)),"^",2) Q
...I $P(NODE,"^",13)!($O(^PSRX(+$G(NODE),1,0))) D Q
....I $P(NODE,"^",13) S PSOMW=$P($G(^PSRX(+$G(NODE),1,$P(NODE,"^",13),0)),"^",2) Q
....F PP=0:0 S PP=$O(^PSRX(+$G(NODE),1,PP)) Q:'PP S PSOMW=$P($G(^PSRX(+$G(NODE),1,PP,0)),"^",2)
...S PSOMW=$P($G(^PSRX(+$G(NODE),0)),"^",11)
..W ?88,$S($G(PSOMW)="W":"WINDOW",1:"MAIL")
..S PSOPRINT=$S($G(^PS(52.5,SINRX,"P")):"YES",1:"NO")
..W ?95,PSOPRINT
..I PSOPRINT="NO" S PSOBAD="" D CHKBAD I PSOBAD'="" W ?103,PSOBAD
..I $G(PSOSCMOP),$P(NODE,"^",7)'="" D
...W ?104,$S($P(NODE,"^",7)="Q":"QUEUED FOR TRANSMISSION",$P(NODE,"^",7)="X":"TRANSMISSION COMPLETED",$P(NODE,"^",7)="L":"LOADING FOR TRANSMISSION",$P(NODE,"^",7)="P":"PRINTED LOCALLY",1:"")
I $E(IOST)'="P",'$G(QFLAG) W ! K DIR S DIR(0)="E" D ^DIR K DIR
W !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
W !,"** END OF REPORT **"
D ^%ZISC G EXIT
HEADB ;
I $E(IOST)'="P",PAGE K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S QFLAG=1 Q
W @IOF
W !,"RX #",?13,"PATIENT",?45,"DRUG",?88,"TYPE",?93,"PRINTED B/D/F",?108,$S($G(PSOSCMOP):"CMOP STATUS",1:""),?122,"PAGE ",$G(PAGE) W !,LINE S PAGE=PAGE+1
Q
HEADND W !!?40,"RX SUSPENSE LIST "_$S($G(PSODATEX)'="":"FOR ",1:"")_$G(PSODATEX)
Q
;
CHKADDR ;
N PSOBADR,PSOTEMP
S PSOBADR=$$BADADR^DGUTL3(PSODFN)
I PSOBADR D
.S PSOTEMP=$$CHKTEMP^PSOBAI(PSODFN)
I PSOBADR,'PSOTEMP S (PSOBAI,PSOBDF("B"))=1 Q
Q
;
FOREIGN ;
N PSOFORGN,DFN
S DFN=PSODFN D ADD^VADPT
S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOBDF("F")=1
Q
;
CHKMAIL ;
N PSOTEMP,MAILEXP
S PSOTEMP=$G(^PS(55,PSODFN,0)) Q:$P(PSOTEMP,"^",3)'=2
S MAILEXP=$P(PSOTEMP,"^",5) I MAILEXP=""!(MAILEXP>DT) S PSOBDF("D")=1
Q
;
CHKBAD ;
K PSOBDF
S PSODFN=PATPTR
D CHKADDR I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
D CHKMAIL I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
D FOREIGN I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
Q
; CHANGE TO USE FOLLOWING IF WANT TO SEE WHY RX'S DID NOT PRINT PREVIOUSLY (INSTEAD OF CURRENT BAD STATUS)
N RX,SEQ,FILL,ZZ
S RX=+$G(NODE),FILL=$P(NODE,"^",13)
S SEQ=0 F S SEQ=$O(^PSRX(RX,"A",SEQ)) Q:'SEQ S X=$G(^PSRX(RX,"A",SEQ,0)) D
.I $P(X,"^",2)="S" S ZZ=$P(X,"^",4),ZZ=$S(ZZ<6:ZZ,1:ZZ-1) I ZZ=FILL,X["due to" D
..I X["DO NOT MAIL" S PSOBAD="D" Q
..I X["BAD ADDRESS" S PSOBAD="B" Q
..I X["FOREIGN ADDRESS" S PSOBAD="F" Q
Q
;
PSOSULOG ;BHAM ISC/RTR-Log of prescriptions on suspense by day ;29-May-2012 15:15;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**18,1008,264;1015**;Build 62;Build 19
+2 ;Modified - IHS/MSC/PLS - 04/30/2009 - Changed references of SSN to HRN
+3 IF '$GET(PSOSITE)
DO ^PSOLSET
IF '$GET(PSOSITE)
DO WARN^PSOSUDCN
QUIT
+4 KILL ^TMP($JOB,"PSOSPLOG")
NEW BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
LOG ;IHS/MSC/PLS - 04/30/2009
+1 ;W ! K DIR S DIR("A")="Sort by Patient Name or SSN",DIR(0)="SB^P:PATIENT NAME;S:SOCIAL SECURITY NUMBER",DIR("B")="PATIENT NAME"
+2 WRITE !
KILL DIR
SET DIR("A")="Sort by Patient Name or HRN"
SET DIR(0)="SB^P:PATIENT NAME;H:HEALTH RECORD NUMBER"
SET DIR("B")="PATIENT NAME"
+3 ;S DIR("?")="Enter 'P' to sort by patient name, 'S' to sort by SSN, enter '^' to exit."
+4 SET DIR("?")="Enter 'P' to sort by patient name, 'H' to sort by HRN, enter '^' to exit."
+5 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MESS
IF $DATA(DIRUT)
GOTO EXIT
SET PSORT=Y
DATE WRITE !
KILL %DT
SET %DT="AEX"
SET %DT("A")="Start Date: "
DO ^%DT
KILL %DT
IF Y=-1&(X'["^")
GOTO DATE
IF X["^"!($DATA(DTOUT))
DO MESS
GOTO EXIT
EDATE WRITE !
SET BDATE=$EXTRACT(Y,1,7)
SET %DT(0)=BDATE
SET %DT="AEX"
SET %DT("A")="End Date: "
DO ^%DT
KILL %DT
IF Y=-1&(X'["^")
GOTO EDATE
IF X["^"!($DATA(DTOUT))
DO MESS
GOTO EXIT
+1 SET EDATE=$EXTRACT(Y,1,7)
WRITE !
+2 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Do you want to see only those Rx's that have NOT yet been printed"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MESS
IF Y["^"!($DATA(DIRUT))
GOTO EXIT
SET PSPRINT=$SELECT(Y:1,1:0)
+3 SET PSOCNT=0
FOR PII=0:0
SET PII=$ORDER(^PS(59,PII))
IF 'PII
QUIT
SET PSOCNT=PSOCNT+1
+4 IF PSOCNT=1
GOTO SKIP
+5 WRITE !!?3,"You are logged in under the "_$PIECE($GET(^PS(59,+$GET(PSOSITE),0)),"^")_" division.",!
+6 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Print only those Rx's suspended for this division"
SET DIR("?")="Enter 'Yes' to print only those Rx's for this division, enter 'No' to print Rx's suspended for all divisions."
+7 DO ^DIR
KILL DIR
IF Y["^"!($DATA(DIRUT))
DO MESS
GOTO EXIT
+8 SET PSUSDIV=Y
SKIP ;
+1 IF '$GET(PSXSYS)
GOTO SKIPC
+2 KILL DIR
WRITE !
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want suspended CMOP Rx's included in this report"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DIRUT))
DO MESS
GOTO EXIT
+3 IF $GET(Y)
SET PSOSCMOP=1
SKIPC ;
+1 WRITE !
KILL DIR
SET DIR("A")="Do you want this report to print in 80 or 132 column format: "
SET DIR("B")="132"
SET DIR(0)="SAM^1:132;8:80"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DIRUT))
DO MESS
GOTO EXIT
+2 WRITE !
SET PSORMZ=$SELECT(Y=1:1,1:0)
+3 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF POP
DO MESS
GOTO EXIT
+4 IF $DATA(IO("Q"))
SET ZTRTN="REP^PSOSULOG"
SET ZTDESC="Report is suspended Rx's"
Begin DoDot:1
+5 FOR GG="PSORMZ","PSOSITE","PSOPAR","PSORT","BDATE","EDATE","PSPRINT","PSUSDIV","PSOSCMOP"
IF $DATA(@GG)
SET ZTSAVE(GG)=""
+6 DO ^%ZTLOAD
WRITE !,"Task queued to print"
End DoDot:1
GOTO EXIT
+7 GOTO REP
EXIT ;
+1 KILL ^TMP($JOB,"PSOSPLOG")
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOBAD,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORMZ,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
+3 QUIT
MESS WRITE !!,"No report printed!",!!
QUIT
REP ;
+1 KILL ^TMP($JOB,"PSOSPLOG")
+2 USE IO
SET $PIECE(LINE,"-",$SELECT($GET(PSORMZ):130,1:79))=""
+3 ;IHS/MSC/PLS - 04/30/09
NEW PHRN,SUSDIV,DIVINS
+4 SET BDATE=BDATE-.0001
SET QFLAG=0
SET PAGE=1
+5 FOR ZZ=BDATE:0
SET ZZ=$ORDER(^PS(52.5,"C",ZZ))
IF 'ZZ!(ZZ>EDATE)
QUIT
FOR SIN=0:0
SET SIN=$ORDER(^PS(52.5,"C",ZZ,SIN))
IF 'SIN
QUIT
Begin DoDot:1
+6 IF '$PIECE($GET(^PS(52.5,SIN,0)),"^",3)
QUIT
+7 IF $GET(PSPRINT)
IF $GET(^PS(52.5,SIN,"P"))
QUIT
+8 IF '$GET(PSOSCMOP)
IF $PIECE($GET(^PS(52.5,SIN,0)),"^",7)'=""
QUIT
+9 IF $GET(PSUSDIV)
IF $GET(PSOSITE)'=$PIECE($GET(^PS(52.5,SIN,0)),"^",6)
QUIT
+10 SET PAT=+$PIECE($GET(^PS(52.5,SIN,0)),"^",3)
IF $PIECE($GET(^DPT(PAT,0)),"^")=""
QUIT
+11 ;IHS/MSC/PLS - 04/30/09
+12 ;I $P($G(^DPT(PAT,0)),"^",9)="",PSORT="S" Q
+13 SET SUSDIV=$PIECE($GET(^PS(52.5,SIN,0)),U,6)
SET DIVINS=+$$GET1^DIQ(59,SUSDIV,100,"I")
+14 SET PHRN=$$HRN^AUPNPAT(PAT,DIVINS)
+15 IF PSORT="H"
IF PHRN<1
QUIT
+16 ;S ^TMP($J,"PSOSPLOG",ZZ,$S(PSORT="P":$P(^DPT(PAT,0),"^"),1:$P(^DPT(PAT,0),"^",9)),SIN)=SIN
+17 SET ^TMP($JOB,"PSOSPLOG",ZZ,$SELECT(PSORT="P":$PIECE(^DPT(PAT,0),"^"),1:PHRN),SIN)=SIN
End DoDot:1
+18 IF $GET(PSORMZ)
GOTO BIG
+19 IF '$DATA(^TMP($JOB,"PSOSPLOG"))
DO HEAD
WRITE !!,"NO RECORDS TO PRINT",!
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+20 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
DO ^%ZISC
GOTO EXIT
+21 SET HPAT=""
SET HDAT=""
+22 FOR PSODATE=0:0
SET PSODATE=$ORDER(^TMP($JOB,"PSOSPLOG",PSODATE))
IF 'PSODATE!($GET(QFLAG))
QUIT
SET (Y,PDAT)=PSODATE
DO DD^%DT
SET PSODATEX=Y
DO HEAD
SET PAT=""
FOR
SET PAT=$ORDER(^TMP($JOB,"PSOSPLOG",PSODATE,PAT))
IF PAT=""!($GET(QFLAG))
QUIT
Begin DoDot:1
+23 FOR SINRX=0:0
SET SINRX=$ORDER(^TMP($JOB,"PSOSPLOG",PSODATE,PAT,SINRX))
IF 'SINRX!($GET(QFLAG))
QUIT
Begin DoDot:2
+24 SET NODE=$GET(^PS(52.5,SINRX,0))
SET PATPTR=+$PIECE(NODE,"^",3)
+25 IF 'PATPTR
QUIT
+26 SET PATNAME=$PIECE($GET(^DPT(PATPTR,0)),"^")
IF PATNAME=""
QUIT
+27 IF $GET(PSPRINT)
IF $GET(^PS(52.5,SINRX,"P"))
QUIT
+28 IF $GET(PSUSDIV)
IF $GET(PSOSITE)'=$PIECE(NODE,"^",6)
QUIT
+29 IF PAT'=HPAT!(HDAT'=PDAT)
WRITE !!?9,"Patient Name: "_$GET(PATNAME)
SET HPAT=PAT
SET PDAT=HDAT
+30 IF ($Y+4)>IOSL
DO HEAD
IF $GET(QFLAG)
QUIT
+31 SET PSOINRX=+$PIECE($GET(NODE),"^")
+32 WRITE !,$PIECE($GET(^PSRX(+$GET(NODE),0)),"^")
+33 WRITE ?13,$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(PSOINRX,0)),"^",6),0)),"^")
+34 KILL PSOMW
Begin DoDot:3
+35 IF $PIECE(NODE,"^",5)
SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),"P",$PIECE(NODE,"^",5),0)),"^",2)
QUIT
+36 IF $PIECE(NODE,"^",13)!($ORDER(^PSRX(+$GET(NODE),1,0)))
Begin DoDot:4
+37 IF $PIECE(NODE,"^",13)
SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),1,$PIECE(NODE,"^",13),0)),"^",2)
QUIT
+38 FOR PP=0:0
SET PP=$ORDER(^PSRX(+$GET(NODE),1,PP))
IF 'PP
QUIT
SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),1,PP,0)),"^",2)
End DoDot:4
QUIT
+39 SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),0)),"^",11)
End DoDot:3
+40 WRITE ?54,$GET(PSOMW)
+41 SET PSOPRINT=$SELECT($GET(^PS(52.5,SINRX,"P")):"YES",1:"NO")
+42 WRITE ?56,PSOPRINT
+43 IF PSOPRINT="NO"
SET PSOBAD=""
DO CHKBAD
IF PSOBAD'=""
WRITE ?62,PSOBAD
+44 IF $GET(PSOSCMOP)
IF $PIECE(NODE,"^",7)'=""
Begin DoDot:3
+45 WRITE ?64,$SELECT($PIECE(NODE,"^",7)="Q":"QUEUED/TRANS",$PIECE(NODE,"^",7)="X":"TRANS/COMPLETE",$PIECE(NODE,"^",7)="L":"LOADING/TRANS",$PIECE(NODE,"^",7)="P":"PRINTED/LOCAL",1:"")
End DoDot:3
End DoDot:2
End DoDot:1
+46 IF $EXTRACT(IOST)'="P"
IF '$GET(QFLAG)
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+47 WRITE !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
+48 WRITE !,"** END OF REPORT **"
+49 DO ^%ZISC
GOTO EXIT
HEAD ;
+1 IF $EXTRACT(IOST)'="P"
IF PAGE
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET QFLAG=1
QUIT
+2 WRITE @IOF
WRITE !?22,"RX SUSPENSE LIST "_$SELECT($GET(PSODATEX)'="":"FOR ",1:"")_$GET(PSODATEX)
WRITE ?68,"PAGE: ",$GET(PAGE)
WRITE !,"RX #",?13,"DRUG",?53,"MW",?56,"PRNT B/D/F",?66,$SELECT($GET(PSOSCMOP):"CMOP STATUS",1:"")
WRITE !,LINE
SET PAGE=PAGE+1
+3 QUIT
BIG ;
+1 NEW PSOPRINT
+2 IF '$DATA(^TMP($JOB,"PSOSPLOG"))
DO HEADB
WRITE !!,"NO RECORDS TO PRINT",!
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
DO ^%ZISC
GOTO EXIT
+4 FOR PSODATE=0:0
SET PSODATE=$ORDER(^TMP($JOB,"PSOSPLOG",PSODATE))
IF 'PSODATE!($GET(QFLAG))
QUIT
SET Y=PSODATE
DO DD^%DT
SET PSODATEX=Y
IF PAGE=1
DO HEADB
DO HEADND
SET PAT=""
FOR
SET PAT=$ORDER(^TMP($JOB,"PSOSPLOG",PSODATE,PAT))
IF PAT=""!($GET(QFLAG))
QUIT
Begin DoDot:1
+5 FOR SINRX=0:0
SET SINRX=$ORDER(^TMP($JOB,"PSOSPLOG",PSODATE,PAT,SINRX))
IF 'SINRX!($GET(QFLAG))
QUIT
Begin DoDot:2
+6 SET NODE=$GET(^PS(52.5,SINRX,0))
SET PATPTR=+$PIECE(NODE,"^",3)
+7 IF 'PATPTR
QUIT
+8 SET PATNAME=$PIECE($GET(^DPT(PATPTR,0)),"^")
IF PATNAME=""
QUIT
+9 IF $GET(PSPRINT)
IF $GET(^PS(52.5,SINRX,"P"))
QUIT
+10 IF $GET(PSUSDIV)
IF $GET(PSOSITE)'=$PIECE(NODE,"^",6)
QUIT
+11 IF ($Y+4)>IOSL
DO HEADB
IF $GET(QFLAG)
QUIT
+12 SET PSOINRX=+$PIECE($GET(NODE),"^")
+13 WRITE !,$PIECE($GET(^PSRX(+$GET(NODE),0)),"^")
+14 WRITE ?13,$GET(PATNAME)
+15 WRITE ?45,$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(PSOINRX,0)),"^",6),0)),"^")
+16 KILL PSOMW
Begin DoDot:3
+17 IF $PIECE(NODE,"^",5)
SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),"P",$PIECE(NODE,"^",5),0)),"^",2)
QUIT
+18 IF $PIECE(NODE,"^",13)!($ORDER(^PSRX(+$GET(NODE),1,0)))
Begin DoDot:4
+19 IF $PIECE(NODE,"^",13)
SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),1,$PIECE(NODE,"^",13),0)),"^",2)
QUIT
+20 FOR PP=0:0
SET PP=$ORDER(^PSRX(+$GET(NODE),1,PP))
IF 'PP
QUIT
SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),1,PP,0)),"^",2)
End DoDot:4
QUIT
+21 SET PSOMW=$PIECE($GET(^PSRX(+$GET(NODE),0)),"^",11)
End DoDot:3
+22 WRITE ?88,$SELECT($GET(PSOMW)="W":"WINDOW",1:"MAIL")
+23 SET PSOPRINT=$SELECT($GET(^PS(52.5,SINRX,"P")):"YES",1:"NO")
+24 WRITE ?95,PSOPRINT
+25 IF PSOPRINT="NO"
SET PSOBAD=""
DO CHKBAD
IF PSOBAD'=""
WRITE ?103,PSOBAD
+26 IF $GET(PSOSCMOP)
IF $PIECE(NODE,"^",7)'=""
Begin DoDot:3
+27 WRITE ?104,$SELECT($PIECE(NODE,"^",7)="Q":"QUEUED FOR TRANSMISSION",$PIECE(NODE,"^",7)="X":"TRANSMISSION COMPLETED",$PIECE(NODE,"^",7)="L":"LOADING FOR TRANSMISSION",$PIECE(NODE,"^",7)="P":"PRINTED LOCALLY",1:"")
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF $EXTRACT(IOST)'="P"
IF '$GET(QFLAG)
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+29 WRITE !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
+30 WRITE !,"** END OF REPORT **"
+31 DO ^%ZISC
GOTO EXIT
HEADB ;
+1 IF $EXTRACT(IOST)'="P"
IF PAGE
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET QFLAG=1
QUIT
+2 WRITE @IOF
+3 WRITE !,"RX #",?13,"PATIENT",?45,"DRUG",?88,"TYPE",?93,"PRINTED B/D/F",?108,$SELECT($GET(PSOSCMOP):"CMOP STATUS",1:""),?122,"PAGE ",$GET(PAGE)
WRITE !,LINE
SET PAGE=PAGE+1
+4 QUIT
HEADND WRITE !!?40,"RX SUSPENSE LIST "_$SELECT($GET(PSODATEX)'="":"FOR ",1:"")_$GET(PSODATEX)
+1 QUIT
+2 ;
CHKADDR ;
+1 NEW PSOBADR,PSOTEMP
+2 SET PSOBADR=$$BADADR^DGUTL3(PSODFN)
+3 IF PSOBADR
Begin DoDot:1
+4 SET PSOTEMP=$$CHKTEMP^PSOBAI(PSODFN)
End DoDot:1
+5 IF PSOBADR
IF 'PSOTEMP
SET (PSOBAI,PSOBDF("B"))=1
QUIT
+6 QUIT
+7 ;
FOREIGN ;
+1 NEW PSOFORGN,DFN
+2 SET DFN=PSODFN
DO ADD^VADPT
+3 SET PSOFORGN=$PIECE($GET(VAPA(25)),"^",2)
IF PSOFORGN'=""
IF PSOFORGN'["UNITED STATES"
SET PSOBDF("F")=1
+4 QUIT
+5 ;
CHKMAIL ;
+1 NEW PSOTEMP,MAILEXP
+2 SET PSOTEMP=$GET(^PS(55,PSODFN,0))
IF $PIECE(PSOTEMP,"^",3)'=2
QUIT
+3 SET MAILEXP=$PIECE(PSOTEMP,"^",5)
IF MAILEXP=""!(MAILEXP>DT)
SET PSOBDF("D")=1
+4 QUIT
+5 ;
CHKBAD ;
+1 KILL PSOBDF
+2 SET PSODFN=PATPTR
+3 DO CHKADDR
IF $DATA(PSOBDF)
SET PSOBAD=$ORDER(PSOBDF(""))
KILL PSOBDF
QUIT
+4 DO CHKMAIL
IF $DATA(PSOBDF)
SET PSOBAD=$ORDER(PSOBDF(""))
KILL PSOBDF
QUIT
+5 DO FOREIGN
IF $DATA(PSOBDF)
SET PSOBAD=$ORDER(PSOBDF(""))
KILL PSOBDF
QUIT
+6 QUIT
+7 ; CHANGE TO USE FOLLOWING IF WANT TO SEE WHY RX'S DID NOT PRINT PREVIOUSLY (INSTEAD OF CURRENT BAD STATUS)
+8 NEW RX,SEQ,FILL,ZZ
+9 SET RX=+$GET(NODE)
SET FILL=$PIECE(NODE,"^",13)
+10 SET SEQ=0
FOR
SET SEQ=$ORDER(^PSRX(RX,"A",SEQ))
IF 'SEQ
QUIT
SET X=$GET(^PSRX(RX,"A",SEQ,0))
Begin DoDot:1
+11 IF $PIECE(X,"^",2)="S"
SET ZZ=$PIECE(X,"^",4)
SET ZZ=$SELECT(ZZ<6:ZZ,1:ZZ-1)
IF ZZ=FILL
IF X["due to"
Begin DoDot:2
+12 IF X["DO NOT MAIL"
SET PSOBAD="D"
QUIT
+13 IF X["BAD ADDRESS"
SET PSOBAD="B"
QUIT
+14 IF X["FOREIGN ADDRESS"
SET PSOBAD="F"
QUIT
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
