PSXNEW.m

PSXNEW ;BIR/HTW/PWC-Rx Order Entry Screen for CMOP ;11 Mar 2002  4:38 PM

 ;;2.0;CMOP;**41**;11 Apr 97

 ; reference to ^PS(52.5 supported by DBIA #1978

 ; reference to ^PSRX    supported by DBIA #1977

 ; reference to EN^PSOHLSN1 supported by DBIA #2385

 ; reference to ^XTMP("ORLK-" supported by DBIA #4001

RESET(PSXRX,PSXFILL,PSXREAS) ;

OERR    ;clear ^XTMP("ORLK" if it is CPRS/CMOP

 N ORD S ORD=+$P($G(^PSRX(+$G(PSXRX),"OR1")),"^",2)

 I ORD,$D(^XTMP("ORLK-"_ORD,0)),^XTMP("ORLK-"_ORD,0)["CPRS/CMOP" K ^XTMP("ORLK-"_ORD)

 ;   Remove and test individual RX's

 N PSXRFD,PSXEDREL,PSOSITE,PSXSD,PSXLFD,PSXDFN,PSX525,PSXD,PSXZ,PSXRXF,PSXFDA

 ;       Q:If tradename

 Q:$G(^PSRX(PSXRX,"TN"))]""

 ;       Q: If Cancelled, Expired, Deleted, Drug Interactions, Hold

 Q:$P(^PSRX(PSXRX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3)

 ;       Find last fill

 S PSXRFD=+$O(^PSRX(PSXRX,1,"A"),-1)

 S PSXEDREL=$S(PSXRFD=0:$P($G(^PSRX(PSXRX,2)),"^",13),1:$P($G(^PSRX(PSXRX,1,PSXRFD,0)),"^",18))

 I PSXEDREL K DA,DIE,DR D

 . I PSXRFD=0 S DA=PSXRX L +^PSRX(DA):600 S DIE="^PSRX(",DR="31///@" D ^DIE L -^PSRX(DA)

 . I PSXRFD>0 S DA=PSXRFD,DA(1)=PSXRX L +^PSRX(DA(1),1,DA):600 S DIE="^PSRX(DA(1),1,",DR="17///@" D ^DIE L -^PSRX(DA(1),1,DA)

SUS ;       Auto-Suspend CMOPS

 N DA,Y

 S DA=PSXRX

 ;D NOW^%DTC ; need to reset back to original suspended date

 I PSXRFD=0 S %=$P(^PSRX(PSXRX,2),"^",2)

 I PSXRFD>0 S %=$P(^PSRX(PSXRX,1,PSXRFD,0),"^",1)

 S PSXSD=$P(%,".",1),PSXLFD=$E(%,4,5)_"-"_$E(%,6,7)_"-"_$E(%,2,3)

 S PSXRXS=$O(^PS(52.5,"B",PSXRX,0))

 I PSXRXS S DA=PSXRXS,DIK="^PS(52.5," D ^DIK S DA=PSXRX

 I $G(PSXRFD)>0 S PSOSITE=$P(^PSRX(PSXRX,1,PSXRFD,0),"^",9)

 I $G(PSXRFD)=0 S PSOSITE=$P(^PSRX(PSXRX,2),"^",9)

 S DIC="^PS(52.5,",DIC(0)="Z"

 K DD,DO S X=PSXRX,PSXDFN=$P(^PSRX(PSXRX,0),"^",2)

 S DIC("DR")=".02////"_PSXSD_";.03////"_PSXDFN_";.04////M;.05////0;.06////"_PSOSITE_";2////0;3////Q;9////"_PSXRFD

 D FILE^DICN K DIC,DIK,DD,DO

 I +Y>0 S PSX525=+Y

 E  D EXIT Q

LOCK525 ;        

 L +^PS(52.5,PSX525):600 G:'$T LOCK525

 K ^PS(52.5,"AC",PSXDFN,PSXSD,PSX525),PSXDFN

 L -^PS(52.5,PSX525)

 D SETRX

 D ACT

 S COMM="Rx# "_$P(^PSRX(PSXRX,0),"^")_" Has Been Suspended for CMOP Until "_PSXLFD_"."

 D EN^PSOHLSN1(PSXRX,"SC","ZS",COMM) K COMM

EXIT K PSXRXS,PSXLFD,PSXRXF,PSXFDA,PSXIR,PSXRX,PSXSD,PSXRXDA,PSXRFD,PSX

 K PSXEDREL,PSOSITE,PSX525,PSXDFN,PSXFIEN,PSXD,DIC,DIE,Y,X,%,%H,%I,%T,I

 Q

SETRX ; Check if last fill has been transmitted (0) or retransmitted (2) - 

 ; edit node and set to not dispensed (3).

 ; If already dispensed (1) or not dispensed (3), create new entry

 ; and set to not dispensed (3) with cancelled reason.

 S $P(^PSRX(PSXRX,"STA"),"^")=5

 K PSX S PSXZ=0

 F  S PSXZ=$O(^PSRX(PSXRX,4,PSXZ)) Q:'PSXZ  D

 . S PSXD=$G(^PSRX(PSXRX,4,PSXZ,0))

 . S FILL=$P(PSXD,U,3)

 . S:FILL'="" PSX($P(PSXD,U,3))=$P(PSXD,U,4)_"^"_PSXZ   ; PSX(FILL)=STATUS^IEN

 Q:'$D(PSX(PSXRFD))    ;last fill does not have entry in multiple

 S PSXST=$P(PSX(PSXRFD),U,1),PSXFIEN=$P(PSX(PSXRFD),U,2)

 I PSXST=0!(PSXST=2) D  Q

 . K DA,DIE,DIC,DR S DIE="^PSRX(DA(1),4,",DA(1)=PSXRX,DA=PSXFIEN

 . S DR="3////3;5////"_PSXSD_";8////"_$G(PSXREAS)

 . L +^PSRX(DA(1),4,DA):600

 . D ^DIE L -^PSRX(DA(1),4,DA) K DIC,DIK,DD,DO

 I PSXST=1!(PSXST=3) D

 . K DD,DO S X="",DIC="^PSRX("_PSXRX_",4,",DIC(0)="Z"

 . S DIC("DR")=".01////"_$P(PSXD,U,1)_";1////"_$P(PSXD,U,2)_";2////"_$P(PSXD,U,3)_";3////3;5////"_PSXSD_";8////"_$G(PSXREAS)

 . D FILE^DICN K DIC,DIK,DD,DO

 Q

ACT ;             adds activity info for CMOP Rx placed on suspense

 I '$D(PSXRXF) S PSXRXF=0 F I=0:0 S I=$O(^PSRX(PSXRX,1,I)) Q:'I  S PSXRXF=I

 S PSXIR=0 F PSXFDA=0:0 S PSXFDA=$O(^PSRX(PSXRX,"A",PSXFDA)) Q:'PSXFDA  S PSXIR=PSXFDA

 S PSXIR=PSXIR+1,^PSRX(PSXRX,"A",0)="^52.3DA^"_PSXIR_"^"_PSXIR

 D NOW^%DTC

 I $G(PSXRXF)>5 S PSXRXF=PSXRXF+1

 ;S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP Disaster Recovery until "_PSXLFD

 S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP "_$G(PSXREAS)_" until "_PSXLFD

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSXNEW   4074     printed  Feb 18, 2025@23:10:56                                                                                                                                                                                                      Page 2

PSXNEW    ;BIR/HTW/PWC-Rx Order Entry Screen for CMOP ;11 Mar 2002  4:38 PM

 +1       ;;2.0;CMOP;**41**;11 Apr 97

 +2       ; reference to ^PS(52.5 supported by DBIA #1978

 +3       ; reference to ^PSRX    supported by DBIA #1977

 +4       ; reference to EN^PSOHLSN1 supported by DBIA #2385

 +5       ; reference to ^XTMP("ORLK-" supported by DBIA #4001

RESET(PSXRX,PSXFILL,PSXREAS) ;

OERR      ;clear ^XTMP("ORLK" if it is CPRS/CMOP

 +1        NEW ORD

           SET ORD=+$PIECE($GET(^PSRX(+$GET(PSXRX),"OR1")),"^",2)

 +2        IF ORD

               IF $DATA(^XTMP("ORLK-"_ORD,0))

                   IF ^XTMP("ORLK-"_ORD,0)["CPRS/CMOP"

                       KILL ^XTMP("ORLK-"_ORD)

 +3       ;   Remove and test individual RX's

 +4        NEW PSXRFD,PSXEDREL,PSOSITE,PSXSD,PSXLFD,PSXDFN,PSX525,PSXD,PSXZ,PSXRXF,PSXFDA

 +5       ;       Q:If tradename

 +6        if $GET(^PSRX(PSXRX,"TN"))]""

               QUIT 

 +7       ;       Q: If Cancelled, Expired, Deleted, Drug Interactions, Hold

 +8        if $PIECE(^PSRX(PSXRX,"STA"),"^")>9!($PIECE(^("STA"),"^")=4)!($PIECE(^("STA"),"^")=3)

               QUIT 

 +9       ;       Find last fill

 +10       SET PSXRFD=+$ORDER(^PSRX(PSXRX,1,"A"),-1)

 +11       SET PSXEDREL=$SELECT(PSXRFD=0:$PIECE($GET(^PSRX(PSXRX,2)),"^",13),1:$PIECE($GET(^PSRX(PSXRX,1,PSXRFD,0)),"^",18))

 +12       IF PSXEDREL

               KILL DA,DIE,DR

               Begin DoDot:1

 +13               IF PSXRFD=0

                       SET DA=PSXRX

                       LOCK +^PSRX(DA):600

                       SET DIE="^PSRX("

                       SET DR="31///@"

                       DO ^DIE

                       LOCK -^PSRX(DA)

 +14               IF PSXRFD>0

                       SET DA=PSXRFD

                       SET DA(1)=PSXRX

                       LOCK +^PSRX(DA(1),1,DA):600

                       SET DIE="^PSRX(DA(1),1,"

                       SET DR="17///@"

                       DO ^DIE

                       LOCK -^PSRX(DA(1),1,DA)

               End DoDot:1

SUS       ;       Auto-Suspend CMOPS

 +1        NEW DA,Y

 +2        SET DA=PSXRX

 +3       ;D NOW^%DTC ; need to reset back to original suspended date

 +4        IF PSXRFD=0

               SET %=$PIECE(^PSRX(PSXRX,2),"^",2)

 +5        IF PSXRFD>0

               SET %=$PIECE(^PSRX(PSXRX,1,PSXRFD,0),"^",1)

 +6        SET PSXSD=$PIECE(%,".",1)

           SET PSXLFD=$EXTRACT(%,4,5)_"-"_$EXTRACT(%,6,7)_"-"_$EXTRACT(%,2,3)

 +7        SET PSXRXS=$ORDER(^PS(52.5,"B",PSXRX,0))

 +8        IF PSXRXS

               SET DA=PSXRXS

               SET DIK="^PS(52.5,"

               DO ^DIK

               SET DA=PSXRX

 +9        IF $GET(PSXRFD)>0

               SET PSOSITE=$PIECE(^PSRX(PSXRX,1,PSXRFD,0),"^",9)

 +10       IF $GET(PSXRFD)=0

               SET PSOSITE=$PIECE(^PSRX(PSXRX,2),"^",9)

 +11       SET DIC="^PS(52.5,"

           SET DIC(0)="Z"

 +12       KILL DD,DO

           SET X=PSXRX

           SET PSXDFN=$PIECE(^PSRX(PSXRX,0),"^",2)

 +13       SET DIC("DR")=".02////"_PSXSD_";.03////"_PSXDFN_";.04////M;.05////0;.06////"_PSOSITE_";2////0;3////Q;9////"_PSXRFD

 +14       DO FILE^DICN

           KILL DIC,DIK,DD,DO

 +15       IF +Y>0

               SET PSX525=+Y

 +16      IF '$TEST

               DO EXIT

               QUIT 

LOCK525   ;        

 +1        LOCK +^PS(52.5,PSX525):600

           if '$TEST

               GOTO LOCK525

 +2        KILL ^PS(52.5,"AC",PSXDFN,PSXSD,PSX525),PSXDFN

 +3        LOCK -^PS(52.5,PSX525)

 +4        DO SETRX

 +5        DO ACT

 +6        SET COMM="Rx# "_$PIECE(^PSRX(PSXRX,0),"^")_" Has Been Suspended for CMOP Until "_PSXLFD_"."

 +7        DO EN^PSOHLSN1(PSXRX,"SC","ZS",COMM)

           KILL COMM

EXIT       KILL PSXRXS,PSXLFD,PSXRXF,PSXFDA,PSXIR,PSXRX,PSXSD,PSXRXDA,PSXRFD,PSX

 +1        KILL PSXEDREL,PSOSITE,PSX525,PSXDFN,PSXFIEN,PSXD,DIC,DIE,Y,X,%,%H,%I,%T,I

 +2        QUIT 

SETRX     ; Check if last fill has been transmitted (0) or retransmitted (2) - 

 +1       ; edit node and set to not dispensed (3).

 +2       ; If already dispensed (1) or not dispensed (3), create new entry

 +3       ; and set to not dispensed (3) with cancelled reason.

 +4        SET $PIECE(^PSRX(PSXRX,"STA"),"^")=5

 +5        KILL PSX

           SET PSXZ=0

 +6        FOR 

               SET PSXZ=$ORDER(^PSRX(PSXRX,4,PSXZ))

               if 'PSXZ

                   QUIT 

               Begin DoDot:1

 +7                SET PSXD=$GET(^PSRX(PSXRX,4,PSXZ,0))

 +8                SET FILL=$PIECE(PSXD,U,3)

 +9       ; PSX(FILL)=STATUS^IEN

                   if FILL'=""

                       SET PSX($PIECE(PSXD,U,3))=$PIECE(PSXD,U,4)_"^"_PSXZ

               End DoDot:1

 +10      ;last fill does not have entry in multiple

           if '$DATA(PSX(PSXRFD))

               QUIT 

 +11       SET PSXST=$PIECE(PSX(PSXRFD),U,1)

           SET PSXFIEN=$PIECE(PSX(PSXRFD),U,2)

 +12       IF PSXST=0!(PSXST=2)

               Begin DoDot:1

 +13               KILL DA,DIE,DIC,DR

                   SET DIE="^PSRX(DA(1),4,"

                   SET DA(1)=PSXRX

                   SET DA=PSXFIEN

 +14               SET DR="3////3;5////"_PSXSD_";8////"_$GET(PSXREAS)

 +15               LOCK +^PSRX(DA(1),4,DA):600

 +16               DO ^DIE

                   LOCK -^PSRX(DA(1),4,DA)

                   KILL DIC,DIK,DD,DO

               End DoDot:1

               QUIT 

 +17       IF PSXST=1!(PSXST=3)

               Begin DoDot:1

 +18               KILL DD,DO

                   SET X=""

                   SET DIC="^PSRX("_PSXRX_",4,"

                   SET DIC(0)="Z"

 +19               SET DIC("DR")=".01////"_$PIECE(PSXD,U,1)_";1////"_$PIECE(PSXD,U,2)_";2////"_$PIECE(PSXD,U,3)_";3////3;5////"_PSXSD_";8////"_$GET(PSXREAS)

 +20               DO FILE^DICN

                   KILL DIC,DIK,DD,DO

               End DoDot:1

 +21       QUIT 

ACT       ;             adds activity info for CMOP Rx placed on suspense

 +1        IF '$DATA(PSXRXF)

               SET PSXRXF=0

               FOR I=0:0

                   SET I=$ORDER(^PSRX(PSXRX,1,I))

                   if 'I

                       QUIT 

                   SET PSXRXF=I

 +2        SET PSXIR=0

           FOR PSXFDA=0:0

               SET PSXFDA=$ORDER(^PSRX(PSXRX,"A",PSXFDA))

               if 'PSXFDA

                   QUIT 

               SET PSXIR=PSXFDA

 +3        SET PSXIR=PSXIR+1

           SET ^PSRX(PSXRX,"A",0)="^52.3DA^"_PSXIR_"^"_PSXIR

 +4        DO NOW^%DTC

 +5        IF $GET(PSXRXF)>5

               SET PSXRXF=PSXRXF+1

 +6       ;S ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP Disaster Recovery until "_PSXLFD

 +7        SET ^PSRX(PSXRX,"A",PSXIR,0)=%_"^S^"_DUZ_"^"_PSXRXF_"^"_" RX Resuspended for CMOP "_$GET(PSXREAS)_" until "_PSXLFD

 +8        QUIT