PSOSUCH1 ;BHAM ISC/JMB-Change suspense and fill/refill dates; Mar 16, 2026@09:30
;;7.0;OUTPATIENT PHARMACY;**148,681,823**;DEC 1997;Build 7
;
; Reference to ^DIC(4 in ICR #2251
; Reference to ^PSXCH in ICR #2206
;
LISTSUS S X="?",DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")<11,$P($G(^PS(52.5,+Y,""P"")),""^"")=0",DIC="^PS(52.5,",DIC(0)="ZQ" D ^DIC K DIC W ! Q:Y<0!($D(DTOUT)) Q
;
LISTPAT S X="?",DIC(0)="EMQ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AC"",+Y))" D ^DIC K DIC Q
;
PSOINST S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^") I Y["-",'$D(^PSRX($P(Y,"-",2),0)) W !,?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G SPEC^PSOSUCHG:ACT="S" G ALL^PSOSUCHG:ACT="A"
I Y["-",$P(Y,"-")'=PSOINST W !,?7,$C(7),$C(7),$C(7)," NOT FROM THIS INSTITUTION" G SPEC^PSOSUCHG:ACT="S" G ALL^PSOSUCHG:ACT="A"
Q
;
AREC ;
N PSODUZ
S PSODUZ=DUZ
I '$D(^VA(200,+PSODUZ,0)) S PSODUZ=.5
I 'DEAD S COM="Change "_$S($G(PSOSUSPA):"Partial",'$G(SUB):"Fill",1:"Refill")_" Date "_$E(OLD,4,5)_"/"_$E(OLD,6,7)_"/"_$E(OLD,2,3)_" to "_$E(INDT,4,5)_"/"_$E(INDT,6,7)_"/"_$E(INDT,2,3)
S CNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXREC,"A",SUB)) Q:'SUB S CNT=SUB
S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXREC,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
D NOW^%DTC
S CNT=CNT+1
S ^PSRX(RXREC,"A",0)="^52.3DA^"_CNT_"^"_CNT
S ^PSRX(RXREC,"A",CNT,0)=%_"^"_$S(DEAD:"C",1:"S")_"^"_PSODUZ_"^"_$S($G(PSOSUSPA):6,1:RFCNT)_"^"_COM
K PSOSUSPA
Q
;
CHKDEAD D DEM^VADPT I VADM(1)="" W !?10,"PATIENT NAME UNKNOWN" S DEAD=0 Q
I VADM(6)="" S DEAD=0 Q
S SUSDOD=$P(VADM(6),"^",2)
F RXREC=0:0 S RXREC=$O(^PS(52.5,"AC",DFN,RXREC)) Q:'RXREC F SRXREC=0:0 S SRXREC=$O(^PS(52.5,"AC",DFN,RXREC,SRXREC)) Q:'SRXREC S RECORD=$P($G(^PS(52.5,SRXREC,0)),"^") D:RECORD DEAD
Q
;
DEAD S HOLD=$G(DA),REA="C",COM="Died ("_$G(SUSDOD)_")",DA=RECORD,DEAD=1 D CAN^PSOCAN
W:'WARN !!,?10,$P($G(^DPT(DFN,0)),"^")_" DIED "_SUSDOD_" all prescriptions were discontinued" W:'WARN !,?15," and deleted from the suspense file." S WARN=1,DA=HOLD K HOLD,REA
Q
;
NEXT S PSOX("IRXN")=RXREC D NEXT^PSOUTIL(.PSOX) S NEXT=$P(PSOX("RX3"),"^",2),DA=RXREC,DIE=52,DR="102///"_NEXT D ^DIE K DIE Q:$D(DTOUT)!($D(DUOUT))
K NEXT,PSOX Q
;
CHANGE(RXREC,SUB) ; File update for Suspense Date change
;PSO*7.0*823: Added PSOAREC
N PSOAREC S PSOAREC=1
I $P($G(^PS(52.5,SFN,0)),"^",5) S PSOSUSPA=1,HDSFN=SFN S SRXPAR=+$P(^(0),"^",5),OLD=+$P($G(^PSRX(RXREC,"P",SRXPAR,0)),"^"),DA(1)=RXREC,DA=SRXPAR,DIE="^PSRX("_DA(1)_",""P"",",DR=".01////"_INDT D ^DIE G FIN
I '$D(SUB) S SUB=0 F II=0:0 S II=$O(^PSRX(RXREC,1,II)) Q:'II S SUB=+II
S HDSFN=SFN I 'SUB S (X,OLD)=$P(^PSRX(RXREC,2),"^",2),DA=RXREC,DR="22///"_INDT_";101///"_INDT,DIE=52 D
.D ^DIE K DIE K:$G(^PS(52.5,HDSFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,HDSFN,0)),"^",2),HDSFN) Q:$D(DTOUT)!($D(DUOUT)) D NEXT K DA Q
I SUB S (OLD,X)=+$P($G(^PSRX(RXREC,1,SUB,0)),"^"),DA(1)=RXREC,DA=SUB,DIE="^PSRX("_DA(1)_",1,",DR=".01///"_INDT D ^DIE K DIE S $P(^PSRX(RXREC,3),"^")=INDT D
.K:$G(^PS(52.5,HDSFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,HDSFN,0)),"^",2),HDSFN) D NEXT S DA=RXREC K DA Q
;PSO*7.0*823: PSOSDLK is set by option "Change Suspense Date".
; No other PSO routines set PSOSDLK.
; A future patch might address related issues with that option.
I '$D(PSOSDLK) D EXP
D FIN
Q
;
EXP ;PSO*7.0*823: Create Mailman message and add activity log for suspense beyond expiration date
N PSOEXPDT,PSOSUS,PSOSUSDT,PSOKEY,PSODUZ,PSORXNUM,PSOUSR,PSOFNSH,PSOCOMNT,XMY,XMDUZ,XMSUB,XMTEXT,XMIN
S PSOEXPDT=$P(^PSRX(RXREC,2),U,6),PSOSUS=$O(^PS(52.5,"B",RXREC,0)),PSOSUSDT=$P(^PS(52.5,PSOSUS,0),U,2)
;No need to send MailMan message if suspense date is not greater than the expiration date.
I PSOSUSDT'>PSOEXPDT Q
S PSORXNUM=$P(^PSRX(RXREC,0),U)
S PSOAREC=0
S PSOSUSDT=$E(PSOSUSDT,4,5)_"/"_$E(PSOSUSDT,6,7)_"/"_$E(PSOSUSDT,2,3)
S PSOEXPDT=$E(PSOEXPDT,4,5)_"/"_$E(PSOEXPDT,6,7)_"/"_$E(PSOEXPDT,2,3)
S PSOKEY=+$O(^DIC(19.1,"B","PSXMAIL",0))
;Create MailMan message
K ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT")
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",1)="A 3/4 days supply hold for Rx #"_PSORXNUM_" suspended the suspense date to "_PSOSUSDT
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",2)="which is on or after the Rx expiration date "_PSOEXPDT_"."
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",3)=""
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",4)="Review the Rx #"_PSORXNUM_" activity log to identify the prior Rx fill impacting"
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",5)="the SUSPENSE HOLD date and determine if ECME actions are necessary to avoid"
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",6)="Rx expiration while on suspense."
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",7)=""
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",8)="This message was sent to the Finishing Pharmacist and PSXMAIL security key"
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",9)="holders."
S ^TMP("PSO SUSPENSE EXPIRATION",$J,"TEXT",10)=""
;Gather Recipients
;Finishing person
S PSOFNSH=$P(^PSRX(RXREC,"OR1"),U,5)
S XMY(PSOFNSH)=""
;Holders of PSXMAIL key
S PSODUZ=0
F S PSODUZ=$O(^VA(200,"AB",PSOKEY,PSODUZ)) Q:'PSODUZ D
. Q:$$GET1^DIQ(200,PSODUZ_",",7,"I")
. S XMY(PSODUZ)=""
S XMSUB="3/4 Days Supply Suspense Hold After Rx Expiration Date"
S XMIN("FROM")="Suspense Background Process"
S XMTEXT="^TMP(""PSO SUSPENSE EXPIRATION"",$J,""TEXT"")"
D SENDMSG^XMXAPI(DUZ,XMSUB,XMTEXT,.XMY,.XMIN,"","")
; Update the Activity Log
S PSOCOMNT="Suspense Date "_PSOSUSDT_" is on or after Expiration Date "_PSOEXPDT_"."
N X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO
S DA(1)=RXREC,DIC="^PSRX("_RXREC_",""A"",",DLAYGO=52.3,DIC(0)="L",X=$$NOW^XLFDT()
S DIC("DR")=".02///E;.03///"_DUZ_";.04///"_$$LSTRFL^PSOBPSU1(RXREC)
S DIC("DR")=DIC("DR")_";.05///"_PSOCOMNT
D FILE^DICN
Q
;PSO*7.0*823 end
;
FIN S DA=HDSFN,DIK="^PS(52.5," D IX1^DIK
S SFN=HDSFN D:PSOAREC AREC N X S X="PSXCH" X ^%ZOSF("TEST") K X Q:'$T D:$G(XOK)=1 X^PSXCH Q
Q
;
DAREC ;
N PSODUZ
S PSODUZ=DUZ
I '$D(^VA(200,+PSODUZ,0)) S PSODUZ=.5
S SCOM="Rx "_$S($P(SNODE,"^",5):"(Partial) ",1:"")_"deleted from suspense"
S SSX=0 F SSXX=0:0 S SSXX=$O(^PSRX(RXREC,"A",SSXX)) Q:'SSXX S SSX=SSXX
S SXCNT=0 F SCXX=0:0 S SCXX=$O(^PSRX(RXREC,1,SCXX)) Q:'SCXX S SXCNT=SCXX S:SCXX>5 SXCNT=SCXX+1
D NOW^%DTC
S SSX=SSX+1
S ^PSRX(RXREC,"A",0)="^52.3DA^"_SSX_"^"_SSX
S ^PSRX(RXREC,"A",SSX,0)=%_"^"_"S"_"^"_PSODUZ_"^"_$S($P(SNODE,"^",5):6,1:SXCNT)_"^"_SCOM
K SCOM,SSX,SSXX,SXCNT,SCXX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUCH1 6586 printed Sep 17, 2026@21:21:16 Page 2
PSOSUCH1 ;BHAM ISC/JMB-Change suspense and fill/refill dates; Mar 16, 2026@09:30
+1 ;;7.0;OUTPATIENT PHARMACY;**148,681,823**;DEC 1997;Build 7
+2 ;
+3 ; Reference to ^DIC(4 in ICR #2251
+4 ; Reference to ^PSXCH in ICR #2206
+5 ;
LISTSUS SET X="?"
SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0)),$P($G(^(""STA"")),""^"")<11,$P($G(^PS(52.5,+Y,""P"")),""^"")=0"
SET DIC="^PS(52.5,"
SET DIC(0)="ZQ"
DO ^DIC
KILL DIC
WRITE !
if Y<0!($DATA(DTOUT))
QUIT
QUIT
+1 ;
LISTPAT SET X="?"
SET DIC(0)="EMQ"
SET DIC="^DPT("
SET DIC("S")="I $D(^PS(52.5,""AC"",+Y))"
DO ^DIC
KILL DIC
QUIT
+1 ;
PSOINST SET PSOINST=$PIECE($GET(^DIC(4,+$PIECE($GET(^XMB(1,1,"XUS")),"^",17),99)),"^")
IF Y["-"
IF '$DATA(^PSRX($PIECE(Y,"-",2),0))
WRITE !,?7,$CHAR(7),$CHAR(7),$CHAR(7)," NON-EXISTENT PRESCRIPTION"
if ACT="S"
GOTO SPEC^PSOSUCHG
if ACT="A"
GOTO ALL^PSOSUCHG
+1 IF Y["-"
IF $PIECE(Y,"-")'=PSOINST
WRITE !,?7,$CHAR(7),$CHAR(7),$CHAR(7)," NOT FROM THIS INSTITUTION"
if ACT="S"
GOTO SPEC^PSOSUCHG
if ACT="A"
GOTO ALL^PSOSUCHG
+2 QUIT
+3 ;
AREC ;
+1 NEW PSODUZ
+2 SET PSODUZ=DUZ
+3 IF '$DATA(^VA(200,+PSODUZ,0))
SET PSODUZ=.5
+4 IF 'DEAD
SET COM="Change "_$SELECT($GET(PSOSUSPA):"Partial",'$GET(SUB):"Fill",1:"Refill")_" Date "_$EXTRACT(OLD,4,5)_"/"_$EXTRACT(OLD,6,7)_"/"_$EXTRACT(OLD,2,3)_" to "_$EXTRACT(INDT,4,5)_"/"_$EXTRACT(INDT,6,7)_"/"_$EXTRACT(INDT,2,3)
+5 SET CNT=0
FOR SUB=0:0
SET SUB=$ORDER(^PSRX(RXREC,"A",SUB))
if 'SUB
QUIT
SET CNT=SUB
+6 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(RXREC,1,RF))
if 'RF
QUIT
SET RFCNT=RF
if RF>5
SET RFCNT=RF+1
+7 DO NOW^%DTC
+8 SET CNT=CNT+1
+9 SET ^PSRX(RXREC,"A",0)="^52.3DA^"_CNT_"^"_CNT
+10 SET ^PSRX(RXREC,"A",CNT,0)=%_"^"_$SELECT(DEAD:"C",1:"S")_"^"_PSODUZ_"^"_$SELECT($GET(PSOSUSPA):6,1:RFCNT)_"^"_COM
+11 KILL PSOSUSPA
+12 QUIT
+13 ;
CHKDEAD DO DEM^VADPT
IF VADM(1)=""
WRITE !?10,"PATIENT NAME UNKNOWN"
SET DEAD=0
QUIT
+1 IF VADM(6)=""
SET DEAD=0
QUIT
+2 SET SUSDOD=$PIECE(VADM(6),"^",2)
+3 FOR RXREC=0:0
SET RXREC=$ORDER(^PS(52.5,"AC",DFN,RXREC))
if 'RXREC
QUIT
FOR SRXREC=0:0
SET SRXREC=$ORDER(^PS(52.5,"AC",DFN,RXREC,SRXREC))
if 'SRXREC
QUIT
SET RECORD=$PIECE($GET(^PS(52.5,SRXREC,0)),"^")
if RECORD
DO DEAD
+4 QUIT
+5 ;
DEAD SET HOLD=$GET(DA)
SET REA="C"
SET COM="Died ("_$GET(SUSDOD)_")"
SET DA=RECORD
SET DEAD=1
DO CAN^PSOCAN
+1 if 'WARN
WRITE !!,?10,$PIECE($GET(^DPT(DFN,0)),"^")_" DIED "_SUSDOD_" all prescriptions were discontinued"
if 'WARN
WRITE !,?15," and deleted from the suspense file."
SET WARN=1
SET DA=HOLD
KILL HOLD,REA
+2 QUIT
+3 ;
NEXT SET PSOX("IRXN")=RXREC
DO NEXT^PSOUTIL(.PSOX)
SET NEXT=$PIECE(PSOX("RX3"),"^",2)
SET DA=RXREC
SET DIE=52
SET DR="102///"_NEXT
DO ^DIE
KILL DIE
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+1 KILL NEXT,PSOX
QUIT
+2 ;
CHANGE(RXREC,SUB) ; File update for Suspense Date change
+1 ;PSO*7.0*823: Added PSOAREC
+2 NEW PSOAREC
SET PSOAREC=1
+3 IF $PIECE($GET(^PS(52.5,SFN,0)),"^",5)
SET PSOSUSPA=1
SET HDSFN=SFN
SET SRXPAR=+$PIECE(^(0),"^",5)
SET OLD=+$PIECE($GET(^PSRX(RXREC,"P",SRXPAR,0)),"^")
SET DA(1)=RXREC
SET DA=SRXPAR
SET DIE="^PSRX("_DA(1)_",""P"","
SET DR=".01////"_INDT
DO ^DIE
GOTO FIN
+4 IF '$DATA(SUB)
SET SUB=0
FOR II=0:0
SET II=$ORDER(^PSRX(RXREC,1,II))
if 'II
QUIT
SET SUB=+II
+5 SET HDSFN=SFN
IF 'SUB
SET (X,OLD)=$PIECE(^PSRX(RXREC,2),"^",2)
SET DA=RXREC
SET DR="22///"_INDT_";101///"_INDT
SET DIE=52
Begin DoDot:1
+6 DO ^DIE
KILL DIE
if $GET(^PS(52.5,HDSFN,"P"))=1
KILL ^PS(52.5,"AC",DFN,+$PIECE($GET(^PS(52.5,HDSFN,0)),"^",2),HDSFN)
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
DO NEXT
KILL DA
QUIT
End DoDot:1
+7 IF SUB
SET (OLD,X)=+$PIECE($GET(^PSRX(RXREC,1,SUB,0)),"^")
SET DA(1)=RXREC
SET DA=SUB
SET DIE="^PSRX("_DA(1)_",1,"
SET DR=".01///"_INDT
DO ^DIE
KILL DIE
SET $PIECE(^PSRX(RXREC,3),"^")=INDT
Begin DoDot:1
+8 if $GET(^PS(52.5,HDSFN,"P"))=1
KILL ^PS(52.5,"AC",DFN,+$PIECE($GET(^PS(52.5,HDSFN,0)),"^",2),HDSFN)
DO NEXT
SET DA=RXREC
KILL DA
QUIT
End DoDot:1
+9 ;PSO*7.0*823: PSOSDLK is set by option "Change Suspense Date".
+10 ; No other PSO routines set PSOSDLK.
+11 ; A future patch might address related issues with that option.
+12 IF '$DATA(PSOSDLK)
DO EXP
+13 DO FIN
+14 QUIT
+15 ;
EXP ;PSO*7.0*823: Create Mailman message and add activity log for suspense beyond expiration date
+1 NEW PSOEXPDT,PSOSUS,PSOSUSDT,PSOKEY,PSODUZ,PSORXNUM,PSOUSR,PSOFNSH,PSOCOMNT,XMY,XMDUZ,XMSUB,XMTEXT,XMIN
+2 SET PSOEXPDT=$PIECE(^PSRX(RXREC,2),U,6)
SET PSOSUS=$ORDER(^PS(52.5,"B",RXREC,0))
SET PSOSUSDT=$PIECE(^PS(52.5,PSOSUS,0),U,2)
+3 ;No need to send MailMan message if suspense date is not greater than the expiration date.
+4 IF PSOSUSDT'>PSOEXPDT
QUIT
+5 SET PSORXNUM=$PIECE(^PSRX(RXREC,0),U)
+6 SET PSOAREC=0
+7 SET PSOSUSDT=$EXTRACT(PSOSUSDT,4,5)_"/"_$EXTRACT(PSOSUSDT,6,7)_"/"_$EXTRACT(PSOSUSDT,2,3)
+8 SET PSOEXPDT=$EXTRACT(PSOEXPDT,4,5)_"/"_$EXTRACT(PSOEXPDT,6,7)_"/"_$EXTRACT(PSOEXPDT,2,3)
+9 SET PSOKEY=+$ORDER(^DIC(19.1,"B","PSXMAIL",0))
+10 ;Create MailMan message
+11 KILL ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT")
+12 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",1)="A 3/4 days supply hold for Rx #"_PSORXNUM_" suspended the suspense date to "_PSOSUSDT
+13 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",2)="which is on or after the Rx expiration date "_PSOEXPDT_"."
+14 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",3)=""
+15 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",4)="Review the Rx #"_PSORXNUM_" activity log to identify the prior Rx fill impacting"
+16 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",5)="the SUSPENSE HOLD date and determine if ECME actions are necessary to avoid"
+17 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",6)="Rx expiration while on suspense."
+18 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",7)=""
+19 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",8)="This message was sent to the Finishing Pharmacist and PSXMAIL security key"
+20 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",9)="holders."
+21 SET ^TMP("PSO SUSPENSE EXPIRATION",$JOB,"TEXT",10)=""
+22 ;Gather Recipients
+23 ;Finishing person
+24 SET PSOFNSH=$PIECE(^PSRX(RXREC,"OR1"),U,5)
+25 SET XMY(PSOFNSH)=""
+26 ;Holders of PSXMAIL key
+27 SET PSODUZ=0
+28 FOR
SET PSODUZ=$ORDER(^VA(200,"AB",PSOKEY,PSODUZ))
if 'PSODUZ
QUIT
Begin DoDot:1
+29 if $$GET1^DIQ(200,PSODUZ_",",7,"I")
QUIT
+30 SET XMY(PSODUZ)=""
End DoDot:1
+31 SET XMSUB="3/4 Days Supply Suspense Hold After Rx Expiration Date"
+32 SET XMIN("FROM")="Suspense Background Process"
+33 SET XMTEXT="^TMP(""PSO SUSPENSE EXPIRATION"",$J,""TEXT"")"
+34 DO SENDMSG^XMXAPI(DUZ,XMSUB,XMTEXT,.XMY,.XMIN,"","")
+35 ; Update the Activity Log
+36 SET PSOCOMNT="Suspense Date "_PSOSUSDT_" is on or after Expiration Date "_PSOEXPDT_"."
+37 NEW X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO
+38 SET DA(1)=RXREC
SET DIC="^PSRX("_RXREC_",""A"","
SET DLAYGO=52.3
SET DIC(0)="L"
SET X=$$NOW^XLFDT()
+39 SET DIC("DR")=".02///E;.03///"_DUZ_";.04///"_$$LSTRFL^PSOBPSU1(RXREC)
+40 SET DIC("DR")=DIC("DR")_";.05///"_PSOCOMNT
+41 DO FILE^DICN
+42 QUIT
+43 ;PSO*7.0*823 end
+44 ;
FIN SET DA=HDSFN
SET DIK="^PS(52.5,"
DO IX1^DIK
+1 SET SFN=HDSFN
if PSOAREC
DO AREC
NEW X
SET X="PSXCH"
XECUTE ^%ZOSF("TEST")
KILL X
if '$TEST
QUIT
if $GET(XOK)=1
DO X^PSXCH
QUIT
+2 QUIT
+3 ;
DAREC ;
+1 NEW PSODUZ
+2 SET PSODUZ=DUZ
+3 IF '$DATA(^VA(200,+PSODUZ,0))
SET PSODUZ=.5
+4 SET SCOM="Rx "_$SELECT($PIECE(SNODE,"^",5):"(Partial) ",1:"")_"deleted from suspense"
+5 SET SSX=0
FOR SSXX=0:0
SET SSXX=$ORDER(^PSRX(RXREC,"A",SSXX))
if 'SSXX
QUIT
SET SSX=SSXX
+6 SET SXCNT=0
FOR SCXX=0:0
SET SCXX=$ORDER(^PSRX(RXREC,1,SCXX))
if 'SCXX
QUIT
SET SXCNT=SCXX
if SCXX>5
SET SXCNT=SCXX+1
+7 DO NOW^%DTC
+8 SET SSX=SSX+1
+9 SET ^PSRX(RXREC,"A",0)="^52.3DA^"_SSX_"^"_SSX
+10 SET ^PSRX(RXREC,"A",SSX,0)=%_"^"_"S"_"^"_PSODUZ_"^"_$SELECT($PIECE(SNODE,"^",5):6,1:SXCNT)_"^"_SCOM
+11 KILL SCOM,SSX,SSXX,SXCNT,SCXX
+12 QUIT
