PSXCH ;BIR/WPB-Routine to Change CMOP RX Suspense Dates ; [ 04/08/97 2:06 PM ]
;;2.0;CMOP;;11 Apr 97
;variable XOK is set based on the value of the CMOP indicator
;and directs processing in the PSOSUCHG routine so that the CMOP
;rxs are processed properly.
P ;
S PSXC=$P($G(^PS(52.5,SFN,0)),U,7),XOK=0
I "QP"[PSXC S XOK=1 G RTN^PSOSUCHG
I "LRX"[PSXC S MESS=$S(PSXC="L":"Rx is being transmitted to the CMOP and CAN NOT be edited.",(PSXC="X")!(PSXC="R"):"Rx has been transmitted to the CMOP and CAN NOT be edited.",1:0) W !,MESS
I XOK=0 K X,Y,RXDATE,RXREC G:ACT="A" ALL^PSOSUCHG D:ACT="S" SPEC^PSOSUCHG
Q
AC ;
K:"XRL"[PSXC ^PS(52.5,"AC",$P(^PS(52.5,SFN,0),"^",3),$P(^PS(52.5,SFN,0),"^",2),SFN)
Q
X ;
S DA=SFN
;following hard kills kill off the old xref
I PSXC="P" K ^PS(52.5,"AP",OLD,$P(^PS(52.5,DA,0),U,3),DA)
I PSXC="Q" K ^PS(52.5,"AQ",OLD,$P(^PS(52.5,DA,0),U,3),DA)
;I PSXC="R" K ^PS(52.5,"AR",OLD,$P(^PS(52.5,DA,0),U,3),DA)
S DA=SFN,DIK(1)="3^AP^AQ^AG",DIK="^PS(52.5," D EN^DIK K DIK,DA,DIK(1)
I $G(PSXC)'="" K ^PS(52.5,"AC",$P(^PS(52.5,SFN,0),U,3),$P(^PS(52.5,SFN,0),U,2),SFN),PSXC,DA,XOK,SFN,MESS,OLD
Q
A ;
S PSXC=$P($G(^PS(52.5,SFN,0)),U,7),XOK=0
S:PSXC="" XOK=2
S:(PSXC'="")&("QP"[PSXC) XOK=1
D:XOK'=0 AC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXCH 1268 printed Oct 16, 2024@17:44:27 Page 2
PSXCH ;BIR/WPB-Routine to Change CMOP RX Suspense Dates ; [ 04/08/97 2:06 PM ]
+1 ;;2.0;CMOP;;11 Apr 97
+2 ;variable XOK is set based on the value of the CMOP indicator
+3 ;and directs processing in the PSOSUCHG routine so that the CMOP
+4 ;rxs are processed properly.
P ;
+1 SET PSXC=$PIECE($GET(^PS(52.5,SFN,0)),U,7)
SET XOK=0
+2 IF "QP"[PSXC
SET XOK=1
GOTO RTN^PSOSUCHG
+3 IF "LRX"[PSXC
SET MESS=$SELECT(PSXC="L":"Rx is being transmitted to the CMOP and CAN NOT be edited.",(PSXC="X")!(PSXC="R"):"Rx has been transmitted to the CMOP and CAN NOT be edited.",1:0)
WRITE !,MESS
+4 IF XOK=0
KILL X,Y,RXDATE,RXREC
if ACT="A"
GOTO ALL^PSOSUCHG
if ACT="S"
DO SPEC^PSOSUCHG
+5 QUIT
AC ;
+1 if "XRL"[PSXC
KILL ^PS(52.5,"AC",$PIECE(^PS(52.5,SFN,0),"^",3),$PIECE(^PS(52.5,SFN,0),"^",2),SFN)
+2 QUIT
X ;
+1 SET DA=SFN
+2 ;following hard kills kill off the old xref
+3 IF PSXC="P"
KILL ^PS(52.5,"AP",OLD,$PIECE(^PS(52.5,DA,0),U,3),DA)
+4 IF PSXC="Q"
KILL ^PS(52.5,"AQ",OLD,$PIECE(^PS(52.5,DA,0),U,3),DA)
+5 ;I PSXC="R" K ^PS(52.5,"AR",OLD,$P(^PS(52.5,DA,0),U,3),DA)
+6 SET DA=SFN
SET DIK(1)="3^AP^AQ^AG"
SET DIK="^PS(52.5,"
DO EN^DIK
KILL DIK,DA,DIK(1)
+7 IF $GET(PSXC)'=""
KILL ^PS(52.5,"AC",$PIECE(^PS(52.5,SFN,0),U,3),$PIECE(^PS(52.5,SFN,0),U,2),SFN),PSXC,DA,XOK,SFN,MESS,OLD
+8 QUIT
A ;
+1 SET PSXC=$PIECE($GET(^PS(52.5,SFN,0)),U,7)
SET XOK=0
+2 if PSXC=""
SET XOK=2
+3 if (PSXC'="")&("QP"[PSXC)
SET XOK=1
+4 if XOK'=0
DO AC
+5 QUIT
