PSXREJ ;BIR/BAB-Rejected Messages Report ;04/08/97 2:06 PM
;;2.0;CMOP;**38**;11 Apr 97
EN ;GET BEGIN DATE
S %DT="AEX",%DT("A")="ENTER BEGINNING DATE: ",%DT("B")="NOW",%DT(0)="-NOW" D ^%DT K %DT,%DT(0),%DT("A"),%DT("B") G:$G(Y)<0!($D(DTOUT)) EXIT
S PSXA=$P(Y,".",1),START=$$FMTE^XLFDT(Y,"1D")
ENDATE ;GET ENDING DATE
S %DT="AEX",%DT("A")="ENTER ENDING DATE: ",%DT("B")="NOW",%DT(0)="-NOW" D ^%DT K %DT,%DT(0),%DT("A"),%DT("B") G:$G(Y)<0!($D(DTOUT)) EXIT
S PSXE=$P(Y,".",1),FINISH=$$FMTE^XLFDT(Y,"1D")
K X,Y
I PSXE<PSXA W !,"Ending date must follow beginning date!" G ENDATE
S PSXA=PSXA-.00001,PSXE=PSXE+.99999
END S %ZIS="Q" D ^%ZIS S PSXLION=ION I POP W !,"No Device Selected" G EXIT
I $D(IO("Q")) D QUE G EXIT
D START,EXIT
Q
QUE ;
S ZTRTN="START^PSXREJ",ZTDESC="CMOP Rejected Messages Report"
S ZTSAVE("PSXB")="",ZTSAVE("PSXDA")=""
S ZTSAVE("PSXLION")="",ZTSAVE("PSXA")="",ZTSAVE("PSXE")=""
S ZTSAVE("START")="",ZTSAVE("FINISH")=""
S ZTIO=PSXLION D ^%ZTLOAD
I $D(ZTSK)[0 W !!,"Job Canceled"
E W !!,"Job Queued"
D HOME^%ZIS Q
;Called by Taskman to start the Rejected Messages Report
START ;
U IO
F S PSXA=$O(^PSX(552.1,"AP",PSXA)) Q:(PSXA']""!(PSXA>PSXE)) D
.S PSXB="" F S PSXB=$O(^PSX(552.1,"AP",PSXA,PSXB)) Q:($G(PSXB)']"") S PSXDA=$O(^PSX(552.1,"AP",PSXA,PSXB,0)) D REF
I '$G(PSXFLAG) W !!,"There were no rejected messages for the date range selected: ",START," to ",FINISH
G EXIT
REF ;
I '$D(^PSX(552.2,"AR",PSXB)) Q
Q:'$D(^PSX(552.1,PSXDA,0))
S SITEN=+$P(^PSX(552.1,PSXDA,0),U,1)
Q:$G(SITEN)']""
;S X=SITEN,DIC="4",DIC(0)="MOZX" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S ST=+Y,SITE=$P(Y,"^",2),PHAR=$P(^PSX(552.1,PSXDA,"P"),U,1) ;****DOD L1
S X=SITEN,AGNCY="VASTANUM" S:$D(^PSX(552,"D",X)) X=$E(X,2,99),AGNCY="DMIS" S ST=$$IEN^XUMF(4,AGNCY,X),SITE=$$GET1^DIQ(4,ST,.01),PHAR=$P(^PSX(552.1,PSXDA,"P"),U,1) ;****DOD L1
S X=$P(^PSX(552.1,PSXDA,0),U,4),TDTM=$$FMTE^XLFDT(X,"1P")
S TOTRX=$P($G(^PSX(552.1,PSXDA,1)),U,4)
S TOTORD=$P($G(^PSX(552.1,PSXDA,1)),U,3)
;
;
S OR1=0
S (REC,CNT)=0 D SUB F S REC=$O(^PSX(552.2,"AR",PSXB,REC)) Q:REC'>0 D GETDATA
;G EXIT
Q
GETDATA ;
S ORDER=$P($G(^PSX(552.2,REC,0)),"^") S ZZ=0
K REASON S REASON=$P($P($G(^PSX(552.2,REC,"ACK")),"MSA|",2),"|",3)
F S ZZ=$O(^PSX(552.2,REC,"T",ZZ)) Q:ZZ'>0 S NODE=$G(^PSX(552.2,REC,"T",ZZ,0)) D
.Q:$E(NODE,1,4)["MSH|"!($E(NODE,1,4)["NTE|")
.I $E(NODE,1,4)["PID|" S NM=$P(NODE,"|",6),SS=$P($P(NODE,"|",4),"^",1),SSN=$E(SS,1,3)_"-"_$E(SS,4,5)_"-"_$E(SS,6,9),NAME=$P(NM,"^",1)_", "_$P(NM,"^",2)
.I $E(NODE,1,4)["ORC|" S ZX=ZZ F S ZX=$O(^PSX(552.2,REC,"T",ZX)) Q:ZX'>0 S TNODE=$G(^PSX(552.2,REC,"T",ZX,0)) D
..Q:$E(TNODE,1,4)["NTE|"
..I $E(TNODE,1,4)["ORC|" S ZZ=ZX Q
..I $E(TNODE,1,4)["RX1|" S DRUGNUM=$P($P(TNODE,"|",15),"^",1),DRUGNM=$P($P(TNODE,"|",15),"^",2),ISSDATE=$P(TNODE,"|",21),EXDATE=$P(TNODE,"|",25),RXNUM=$P(TNODE,"|",27),IDATE=$E(ISSDATE,5,6)_"/"_$E(ISSDATE,7,8)_"/"_$E(ISSDATE,3,4) D Q
...S EDATE=$E(EXDATE,5,6)_"/"_$E(EXDATE,7,8)_"/"_$E(EXDATE,3,4)
..I $E(TNODE,1,4)["ZX1|" S BAR=$P(TNODE,"|",16) D LIST Q
..D LIST
Q
EXIT K TTNODE,IDATE,EDATE,BAR,BRUGNUM,EXDATE,ISSDATE,TNODE,DRUGNM,RXNUM,NODE,NEXT,NEXT2,NM,SS,ZZ,BAT,PHAR,SITE,ST,TDTM,LINE,CNT,TOTORD,TOTRX,RECD,SITEN,X,BEG,END,PSOION,PSXLION,DIC,Y,PSXA,PSXE,PSX1
K %ZIS,I,NAME,ORDER,PSXB,PSXDA,REC,SSN,ZTDESC,ZTIO,ZTSAVE,ZTSK,ZX,PSXFLAG,DIROUT,DIRUT,DTOUT,DUOUT,DIR,FINISH
K %DT,%DT(0),%DT("A"),%DT("B")
D ^%ZISC I $D(IO("Q")) K IO("Q")
S:$D(ZTQUEUED) ZTREQ="@"
Q
SUB W @IOF,?18,"CMOP Rejected Messages for Transmission # ",PSXB,!
D NOW^%DTC S Y=% X ^DD("DD") W ?23,"Printed : ",Y,!! K Y,%
W "Facility : ",SITE,?40,"Division: ",PHAR
W !,"Received on ",$P(TDTM,":",1,2),?40,"Total Orders: ",TOTORD,?60,"Total Rx's: ",TOTRX,!
SUB1 W !,"ORDER",?15,"NAME",?28,"RX NUMBER",?39,"BAR CODE",?54,"DRUG NAME"
W ! S LINE="-" F I=0:1:79 W LINE
W ! S CNT=CNT+6
Q
LIST I ORDER'=OR1 W !!,$P(ORDER,"-",3)," REJECTED REASON: ",REASON
W !,?6,$S($G(NAME1)'=NAME:$E(NAME,1,20),1:"")
W ?28,RXNUM,?39,BAR,?54,$E(DRUGNM,1,25)
S NAME1=NAME
S CNT=CNT+1,OR1=ORDER,PSXFLAG=1
I CNT>56 D SUB1 S CNT=0
K DRUGNUM,DRUGNM,RXNUM,ISSDATE,EXDATE,BAR,REASON
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXREJ 4233 printed Nov 22, 2024@16:55:02 Page 2
PSXREJ ;BIR/BAB-Rejected Messages Report ;04/08/97 2:06 PM
+1 ;;2.0;CMOP;**38**;11 Apr 97
EN ;GET BEGIN DATE
+1 SET %DT="AEX"
SET %DT("A")="ENTER BEGINNING DATE: "
SET %DT("B")="NOW"
SET %DT(0)="-NOW"
DO ^%DT
KILL %DT,%DT(0),%DT("A"),%DT("B")
if $GET(Y)<0!($DATA(DTOUT))
GOTO EXIT
+2 SET PSXA=$PIECE(Y,".",1)
SET START=$$FMTE^XLFDT(Y,"1D")
ENDATE ;GET ENDING DATE
+1 SET %DT="AEX"
SET %DT("A")="ENTER ENDING DATE: "
SET %DT("B")="NOW"
SET %DT(0)="-NOW"
DO ^%DT
KILL %DT,%DT(0),%DT("A"),%DT("B")
if $GET(Y)<0!($DATA(DTOUT))
GOTO EXIT
+2 SET PSXE=$PIECE(Y,".",1)
SET FINISH=$$FMTE^XLFDT(Y,"1D")
+3 KILL X,Y
+4 IF PSXE<PSXA
WRITE !,"Ending date must follow beginning date!"
GOTO ENDATE
+5 SET PSXA=PSXA-.00001
SET PSXE=PSXE+.99999
END SET %ZIS="Q"
DO ^%ZIS
SET PSXLION=ION
IF POP
WRITE !,"No Device Selected"
GOTO EXIT
+1 IF $DATA(IO("Q"))
DO QUE
GOTO EXIT
+2 DO START
DO EXIT
+3 QUIT
QUE ;
+1 SET ZTRTN="START^PSXREJ"
SET ZTDESC="CMOP Rejected Messages Report"
+2 SET ZTSAVE("PSXB")=""
SET ZTSAVE("PSXDA")=""
+3 SET ZTSAVE("PSXLION")=""
SET ZTSAVE("PSXA")=""
SET ZTSAVE("PSXE")=""
+4 SET ZTSAVE("START")=""
SET ZTSAVE("FINISH")=""
+5 SET ZTIO=PSXLION
DO ^%ZTLOAD
+6 IF $DATA(ZTSK)[0
WRITE !!,"Job Canceled"
+7 IF '$TEST
WRITE !!,"Job Queued"
+8 DO HOME^%ZIS
QUIT
+9 ;Called by Taskman to start the Rejected Messages Report
START ;
+1 USE IO
+2 FOR
SET PSXA=$ORDER(^PSX(552.1,"AP",PSXA))
if (PSXA']""!(PSXA>PSXE))
QUIT
Begin DoDot:1
+3 SET PSXB=""
FOR
SET PSXB=$ORDER(^PSX(552.1,"AP",PSXA,PSXB))
if ($GET(PSXB)']"")
QUIT
SET PSXDA=$ORDER(^PSX(552.1,"AP",PSXA,PSXB,0))
DO REF
End DoDot:1
+4 IF '$GET(PSXFLAG)
WRITE !!,"There were no rejected messages for the date range selected: ",START," to ",FINISH
+5 GOTO EXIT
REF ;
+1 IF '$DATA(^PSX(552.2,"AR",PSXB))
QUIT
+2 if '$DATA(^PSX(552.1,PSXDA,0))
QUIT
+3 SET SITEN=+$PIECE(^PSX(552.1,PSXDA,0),U,1)
+4 if $GET(SITEN)']""
QUIT
+5 ;S X=SITEN,DIC="4",DIC(0)="MOZX" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S ST=+Y,SITE=$P(Y,"^",2),PHAR=$P(^PSX(552.1,PSXDA,"P"),U,1) ;****DOD L1
+6 ;****DOD L1
SET X=SITEN
SET AGNCY="VASTANUM"
if $DATA(^PSX(552,"D",X))
SET X=$EXTRACT(X,2,99)
SET AGNCY="DMIS"
SET ST=$$IEN^XUMF(4,AGNCY,X)
SET SITE=$$GET1^DIQ(4,ST,.01)
SET PHAR=$PIECE(^PSX(552.1,PSXDA,"P"),U,1)
+7 SET X=$PIECE(^PSX(552.1,PSXDA,0),U,4)
SET TDTM=$$FMTE^XLFDT(X,"1P")
+8 SET TOTRX=$PIECE($GET(^PSX(552.1,PSXDA,1)),U,4)
+9 SET TOTORD=$PIECE($GET(^PSX(552.1,PSXDA,1)),U,3)
+10 ;
+11 ;
+12 SET OR1=0
+13 SET (REC,CNT)=0
DO SUB
FOR
SET REC=$ORDER(^PSX(552.2,"AR",PSXB,REC))
if REC'>0
QUIT
DO GETDATA
+14 ;G EXIT
+15 QUIT
GETDATA ;
+1 SET ORDER=$PIECE($GET(^PSX(552.2,REC,0)),"^")
SET ZZ=0
+2 KILL REASON
SET REASON=$PIECE($PIECE($GET(^PSX(552.2,REC,"ACK")),"MSA|",2),"|",3)
+3 FOR
SET ZZ=$ORDER(^PSX(552.2,REC,"T",ZZ))
if ZZ'>0
QUIT
SET NODE=$GET(^PSX(552.2,REC,"T",ZZ,0))
Begin DoDot:1
+4 if $EXTRACT(NODE,1,4)["MSH|"!($EXTRACT(NODE,1,4)["NTE|")
QUIT
+5 IF $EXTRACT(NODE,1,4)["PID|"
SET NM=$PIECE(NODE,"|",6)
SET SS=$PIECE($PIECE(NODE,"|",4),"^",1)
SET SSN=$EXTRACT(SS,1,3)_"-"_$EXTRACT(SS,4,5)_"-"_$EXTRACT(SS,6,9)
SET NAME=$PIECE(NM,"^",1)_", "_$PIECE(NM,"^",2)
+6 IF $EXTRACT(NODE,1,4)["ORC|"
SET ZX=ZZ
FOR
SET ZX=$ORDER(^PSX(552.2,REC,"T",ZX))
if ZX'>0
QUIT
SET TNODE=$GET(^PSX(552.2,REC,"T",ZX,0))
Begin DoDot:2
+7 if $EXTRACT(TNODE,1,4)["NTE|"
QUIT
+8 IF $EXTRACT(TNODE,1,4)["ORC|"
SET ZZ=ZX
QUIT
+9 IF $EXTRACT(TNODE,1,4)["RX1|"
SET DRUGNUM=$PIECE($PIECE(TNODE,"|",15),"^",1)
SET DRUGNM=$PIECE($PIECE(TNODE,"|",15),"^",2)
SET ISSDATE=$PIECE(TNODE,"|",21)
SET EXDATE=$PIECE(TNODE,"|",25)
SET RXNUM=$PIECE(TNODE,"|",27)
SET IDATE=$EXTRACT(ISSDATE,5,6)_"/"_$EXTRACT(ISSDATE,7,8)_"/"_$EXTRACT(ISSDATE,3,4)
Begin DoDot:3
+10 SET EDATE=$EXTRACT(EXDATE,5,6)_"/"_$EXTRACT(EXDATE,7,8)_"/"_$EXTRACT(EXDATE,3,4)
End DoDot:3
QUIT
+11 IF $EXTRACT(TNODE,1,4)["ZX1|"
SET BAR=$PIECE(TNODE,"|",16)
DO LIST
QUIT
+12 DO LIST
End DoDot:2
End DoDot:1
+13 QUIT
EXIT KILL TTNODE,IDATE,EDATE,BAR,BRUGNUM,EXDATE,ISSDATE,TNODE,DRUGNM,RXNUM,NODE,NEXT,NEXT2,NM,SS,ZZ,BAT,PHAR,SITE,ST,TDTM,LINE,CNT,TOTORD,TOTRX,RECD,SITEN,X,BEG,END,PSOION,PSXLION,DIC,Y,PSXA,PSXE,PSX1
+1 KILL %ZIS,I,NAME,ORDER,PSXB,PSXDA,REC,SSN,ZTDESC,ZTIO,ZTSAVE,ZTSK,ZX,PSXFLAG,DIROUT,DIRUT,DTOUT,DUOUT,DIR,FINISH
+2 KILL %DT,%DT(0),%DT("A"),%DT("B")
+3 DO ^%ZISC
IF $DATA(IO("Q"))
KILL IO("Q")
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
SUB WRITE @IOF,?18,"CMOP Rejected Messages for Transmission # ",PSXB,!
+1 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE ?23,"Printed : ",Y,!!
KILL Y,%
+2 WRITE "Facility : ",SITE,?40,"Division: ",PHAR
+3 WRITE !,"Received on ",$PIECE(TDTM,":",1,2),?40,"Total Orders: ",TOTORD,?60,"Total Rx's: ",TOTRX,!
SUB1 WRITE !,"ORDER",?15,"NAME",?28,"RX NUMBER",?39,"BAR CODE",?54,"DRUG NAME"
+1 WRITE !
SET LINE="-"
FOR I=0:1:79
WRITE LINE
+2 WRITE !
SET CNT=CNT+6
+3 QUIT
LIST IF ORDER'=OR1
WRITE !!,$PIECE(ORDER,"-",3)," REJECTED REASON: ",REASON
+1 WRITE !,?6,$SELECT($GET(NAME1)'=NAME:$EXTRACT(NAME,1,20),1:"")
+2 WRITE ?28,RXNUM,?39,BAR,?54,$EXTRACT(DRUGNM,1,25)
+3 SET NAME1=NAME
+4 SET CNT=CNT+1
SET OR1=ORDER
SET PSXFLAG=1
+5 IF CNT>56
DO SUB1
SET CNT=0
+6 KILL DRUGNUM,DRUGNM,RXNUM,ISSDATE,EXDATE,BAR,REASON
+7 QUIT
