PSXCH.m

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

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