PSXRXU ;BIR/WPB,HTW,BAB-Remote Facility File Utilities ;14 Dec 2001
;;2.0;CMOP;**3,28,41,57,48,70**;11 Apr 97;Build 9
; Reference to ^PS(52.5, supported by DBIA #1978
; Reference to ^PSOHLSN1 supported by DBIA #2385
; Reference to ^PSRX( supported by DBIA #1977
; Reference to ^XTMP("ORLK-" supported by DBIA #4001
; Reference to $$GETNDC^PSONDCUT supported by DBIA #4705
; Reference to $$MGONFILE^PSOFDAUT(RX) supported by DBIA #5740
START ;files transmission data in file 52 52.5 after transmission is sent
; and clear OERR lock ^XTMP("ORLK-"
; setup error trap for updating RXs in 52 & 52.5
D
. I '$D(^XTMP("PSXAUTOERR")) N $ETRAP,$ESTACK S $ETRAP="D RXERR^PSXRXU"
. D START1
Q
START1 ;
S PSXNM="",PSXMSG=0
F S PSXNM=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM)) Q:PSXNM']"" D
. S DFN="" F S DFN=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN)) Q:DFN'>0 D
.. S RX=0,PSXMSG=PSXMSG+1 F S RX=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX)) Q:RX'>0 D
... S RXF=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX,0))
... D FILE
Q
F D FILE^DICN
Q
FILE ;files the data in the CMOP event multiple of PSRX(
;update 52, 52.5 called from PSXBLD RX loop
S FILL=+RXF
S:$G(PSXTDT)="" PSXTDT=$P(^PSX(550.2,PSXBAT,0),"^",6)
Q:'$D(^PSRX(RX,0))
;S PSXMSG=$P(^PSX(550.1,XX,0),"^")
; update RX, RX:CMOP multiple
;If Rx status = suspended (5) set to active (0)
I $P(^PSRX(RX,"STA"),U,1)=5 S $P(^PSRX(RX,"STA"),U,1)=0
D EN^PSOHLSN1(RX,"SC","ZU","Transmitted to CMOP","")
S:'$D(^PSRX(RX,4,0)) ^PSRX(RX,4,0)="^52.01DA^^"
K DD,DO,DIE,DA,DIC,DR
;VMP OIFO BAY PINES;ELR;PSX*2*57 REMOVE LOCK AND UNLOCK OF PSRX(4
;L +^PSRX(RX,4,0):600 Q:'$T
S DA(1)=RX,DIC="^PSRX("_RX_",4,",DIC(0)="Z",X=PSXBAT
S DIC("DR")="1////"_$G(PSXMSG)_";2////"_$G(FILL)_";3////0;12///"_$S($$PATCH^XPDUTL("PSO*7.0*148"):$$GETNDC^PSONDCUT(RX,FILL),1:"")
I $$MGONFILE^PSOFDAUT(RX) D
. S DIC("DR")=DIC("DR")_";35///"_$P($$MGONFILE^PSOFDAUT(RX),"^",2)
D:'$D(^PSRX(RX,4,"B",PSXBAT)) FILE^DICN I 1
E S DIE=DIC,DR=DIC("DR"),DA=$O(^PSRX(RX,4,"B",PSXBAT,0)) K DIC D ^DIE
K DIC,DA,DR,DIE
;L -^PSRX(RX,4,0)
K FAC
S FAC=$$GET1^DIQ(550.2,PSXBAT,3)
S COM=$S($G(PSXRTRN):"Re-",1:"")_"Transmitted to "_FAC_" CMOP"
S:$G(FILL)>5 FILL=$G(FILL)+1
S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ S CNT=JJ
S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
;VMP OIFO BAY PINES;ELR;PSX*2*57 REMOVE LOCK AND UNLOCK OF PSRX
;L +^PSRX(RX):600 Q:'$T
S ^PSRX(RX,"A",CNT,0)=PSXTDT_"^B^"_DUZ_"^"_$G(FILL)_"^"_COM
;L -^PSRX(RX)
S IN525=$O(^PS(52.5,"B",RX,""))
I $G(IN525)]"" K DIE,DA,DR,DIE,DIC S DIE="^PS(52.5,",DR="3////X",DA=IN525 L +^PS(52.5,IN525):600 Q:'$T D ^DIE L -^PS(52.5,IN525) K DA,DIE,DA,IN525
K DIE,DR,DA
S DA=PSXMSG,DIE="^PSX(550.1,",DR="1////5"
L +^PSX(550.1,PSXMSG):600 Q:'$T
D ^DIE L -^PSX(550.1,PSXMSG) K DA,DR,DIE
OERR ;clear ^XTMP("ORLK-" if it is CPRS/CMOP
N ORD S ORD=+$P($G(^PSRX(+$G(RX),"OR1")),"^",2)
I ORD,$D(^XTMP("ORLK-"_ORD,0)),^XTMP("ORLK-"_ORD,0)["CPRS/CMOP" K ^XTMP("ORLK-"_ORD)
Q
PRINT D NOW^%DTC S DTTM=% S COM="CMOP Suspense Label "_$S($G(^PS(52.5,REC,"P"))=0:"Printed",1:"RePrinted")_$S($G(^PSRX(PTR,"TYPE"))>0:" (PARTIAL)",1:"")
S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(PTR,"A",JJ)) Q:'JJ S CNT=JJ
S $P(^PSRX(PTR,"STA"),"^",1)=0,^PS(52.5,REC,"P")=1
S CNT=CNT+1,^PSRX(PTR,"A",0)="^52.3DA^"_CNT_"^"_CNT L +^PSRX(PTR):600 Q:'$T S ^PSRX(PTR,"A",CNT,0)=DTTM_"^S^"_DUZ_"^"_FILL_"^"_COM L -^PSRX(PTR)
K DTTM,%,COM,CNT,JJ
Q
SUSPS ;goes through the PS(550.1 file and gets the pointer for each rx in PSRX
;CMOP Event entry
S XXX=0 F S XXX=$O(^PSX(550.1,REC,2,XXX)) Q:XXX'>0 D ACLOG
K XXX
Q
ACLOG ;
D NOW^%DTC
S PSXPTR=$P($G(^PSX(550.1,REC,2,XXX,0)),U,1)
F RCC=0:0 S RCC=$O(^PSRX(+PSXPTR,4,"B",OLDBAT,RCC)) Q:RCC="" S RC=RCC
S TRNN=$P($G(^PSRX(+PSXPTR,4,RC,0)),"^",1)
S FAC=$$GET1^DIQ(550.2,TRNN,3)
S FILL=$P($G(^PSRX(+PSXPTR,4,RC,0)),"^",3)
S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(+PSXPTR,"A",JJ)) Q:'JJ S CNT=JJ
S COMMENT="Retransmitted to "_FAC_" CMOP"
S CNT=CNT+1,^PSRX(+PSXPTR,"A",0)="^52.3DA^"_CNT_"^"_CNT
L +^PSRX(+PSXPTR):600 Q:'$T
S ^PSRX(+PSXPTR,"A",CNT,0)=%_U_"B"_U_DUZ_U_$S(FILL>5:(FILL+1),1:FILL)_U_COMMENT
L -^PSRX(+PSXPTR)
L +^PSRX(+PSXPTR,4,0):600 Q:'$T
S DA(1)=+PSXPTR,DIE="^PSRX("_+PSXPTR_",4,",DA=RC,DR="3////2"
D ^DIE K DIE,DA,DR,DD,DO
S:'$D(^PSRX(+PSXPTR,4,0)) ^PSRX(+PSXPTR,4,0)="^52.01DA^^"
S DA(1)=+PSXPTR,DIC="^PSRX("_+PSXPTR_",4,",DIC(0)="Z",X=PSXBAT
S DIC("DR")="1////"_REC_";2////"_$G(FILL)_";3////0" D F
L -^PSRX(+PSXPTR,4,0)
K PSXPTR,COMMENT,CNT,JJ,FILL,REF,%,DIC,DA,DIE,DR
S DA=REC,DIE="^PSX(550.1,",DR="1////5" L +^PSX(550.1,REC):600 Q:'$T
D ^DIE L -^PSX(550.1,REC) K DIE,DA,DR,FAC,TRNN
Q
RXERR ;auto error processing of RX updating 52 & 52.5
S XXERR=$$EC^%ZOSV
S PSXDIVNM=$$GET1^DIQ(59,PSOSITE,.01)
;save an image of the transient file 550.1 for 2 days
D NOW^%DTC S DTTM=%
;VMP OIFO BAY PINES;ELR;PSX*2*57 CHANE PURGE DATE TO T+12 FROM T+2
S X=$$FMADD^XLFDT(DT,+12) S ^XTMP("PSXERR "_DTTM,0)=X_U_DT_U_"CMOP "_XXERR
M ^XTMP("PSXERR "_DTTM,550.1)=^PSX(550.1)
S XMSUB="CMOP Error "_PSXDIVNM_" "_$$GET1^DIQ(550.2,+$G(PSXBAT),.01)
D GRP1^PSXNOTE
;S XMY(DUZ)=""
S XMTEXT="TEXT("
S TEXT(1,0)=$S($G(PSXCS):"",1:"NON-")_"CS CMOP transmission encountered the following error. Please investigate"
S TEXT(2,0)="Division: "_PSXDIVNM
S TEXT(3,0)="Type/Batch "_$S($G(PSXCS):"CS",1:"NON-CS")_" / "_$$GET1^DIQ(550.2,$G(PSXBAT),.01)
S TEXT(4,0)="Error: "_XXERR
S TEXT(5,0)=">>>This batch has been sent <<<"
S TEXT(6,0)="Call NVS to investigate which prescriptions have been updated"
S TEXT(7,0)="or not updated in files Prescription #52 & Suspense 52.5 ."
S TEXT(8,0)="A copy of file 550.1 can be found in ^XTMP(""PSXERR "_DTTM_""")"
D ^%ZTER
D ^XMD
G UNWIND^%ZTER
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXRXU 5858 printed Dec 13, 2024@01:45:09 Page 2
PSXRXU ;BIR/WPB,HTW,BAB-Remote Facility File Utilities ;14 Dec 2001
+1 ;;2.0;CMOP;**3,28,41,57,48,70**;11 Apr 97;Build 9
+2 ; Reference to ^PS(52.5, supported by DBIA #1978
+3 ; Reference to ^PSOHLSN1 supported by DBIA #2385
+4 ; Reference to ^PSRX( supported by DBIA #1977
+5 ; Reference to ^XTMP("ORLK-" supported by DBIA #4001
+6 ; Reference to $$GETNDC^PSONDCUT supported by DBIA #4705
+7 ; Reference to $$MGONFILE^PSOFDAUT(RX) supported by DBIA #5740
START ;files transmission data in file 52 52.5 after transmission is sent
+1 ; and clear OERR lock ^XTMP("ORLK-"
+2 ; setup error trap for updating RXs in 52 & 52.5
+3 Begin DoDot:1
+4 IF '$DATA(^XTMP("PSXAUTOERR"))
NEW $ETRAP,$ESTACK
SET $ETRAP="D RXERR^PSXRXU"
+5 DO START1
End DoDot:1
+6 QUIT
START1 ;
+1 SET PSXNM=""
SET PSXMSG=0
+2 FOR
SET PSXNM=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM))
if PSXNM']""
QUIT
Begin DoDot:1
+3 SET DFN=""
FOR
SET DFN=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN))
if DFN'>0
QUIT
Begin DoDot:2
+4 SET RX=0
SET PSXMSG=PSXMSG+1
FOR
SET RX=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX))
if RX'>0
QUIT
Begin DoDot:3
+5 SET RXF=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX,0))
+6 DO FILE
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
F DO FILE^DICN
+1 QUIT
FILE ;files the data in the CMOP event multiple of PSRX(
+1 ;update 52, 52.5 called from PSXBLD RX loop
+2 SET FILL=+RXF
+3 if $GET(PSXTDT)=""
SET PSXTDT=$PIECE(^PSX(550.2,PSXBAT,0),"^",6)
+4 if '$DATA(^PSRX(RX,0))
QUIT
+5 ;S PSXMSG=$P(^PSX(550.1,XX,0),"^")
+6 ; update RX, RX:CMOP multiple
+7 ;If Rx status = suspended (5) set to active (0)
+8 IF $PIECE(^PSRX(RX,"STA"),U,1)=5
SET $PIECE(^PSRX(RX,"STA"),U,1)=0
+9 DO EN^PSOHLSN1(RX,"SC","ZU","Transmitted to CMOP","")
+10 if '$DATA(^PSRX(RX,4,0))
SET ^PSRX(RX,4,0)="^52.01DA^^"
+11 KILL DD,DO,DIE,DA,DIC,DR
+12 ;VMP OIFO BAY PINES;ELR;PSX*2*57 REMOVE LOCK AND UNLOCK OF PSRX(4
+13 ;L +^PSRX(RX,4,0):600 Q:'$T
+14 SET DA(1)=RX
SET DIC="^PSRX("_RX_",4,"
SET DIC(0)="Z"
SET X=PSXBAT
+15 SET DIC("DR")="1////"_$GET(PSXMSG)_";2////"_$GET(FILL)_";3////0;12///"_$SELECT($$PATCH^XPDUTL("PSO*7.0*148"):$$GETNDC^PSONDCUT(RX,FILL),1:"")
+16 IF $$MGONFILE^PSOFDAUT(RX)
Begin DoDot:1
+17 SET DIC("DR")=DIC("DR")_";35///"_$PIECE($$MGONFILE^PSOFDAUT(RX),"^",2)
End DoDot:1
+18 if '$DATA(^PSRX(RX,4,"B",PSXBAT))
DO FILE^DICN
IF 1
+19 IF '$TEST
SET DIE=DIC
SET DR=DIC("DR")
SET DA=$ORDER(^PSRX(RX,4,"B",PSXBAT,0))
KILL DIC
DO ^DIE
+20 KILL DIC,DA,DR,DIE
+21 ;L -^PSRX(RX,4,0)
+22 KILL FAC
+23 SET FAC=$$GET1^DIQ(550.2,PSXBAT,3)
+24 SET COM=$SELECT($GET(PSXRTRN):"Re-",1:"")_"Transmitted to "_FAC_" CMOP"
+25 if $GET(FILL)>5
SET FILL=$GET(FILL)+1
+26 SET CNT=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(RX,"A",JJ))
if 'JJ
QUIT
SET CNT=JJ
+27 SET CNT=CNT+1
SET ^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
+28 ;VMP OIFO BAY PINES;ELR;PSX*2*57 REMOVE LOCK AND UNLOCK OF PSRX
+29 ;L +^PSRX(RX):600 Q:'$T
+30 SET ^PSRX(RX,"A",CNT,0)=PSXTDT_"^B^"_DUZ_"^"_$GET(FILL)_"^"_COM
+31 ;L -^PSRX(RX)
+32 SET IN525=$ORDER(^PS(52.5,"B",RX,""))
+33 IF $GET(IN525)]""
KILL DIE,DA,DR,DIE,DIC
SET DIE="^PS(52.5,"
SET DR="3////X"
SET DA=IN525
LOCK +^PS(52.5,IN525):600
if '$TEST
QUIT
DO ^DIE
LOCK -^PS(52.5,IN525)
KILL DA,DIE,DA,IN525
+34 KILL DIE,DR,DA
+35 SET DA=PSXMSG
SET DIE="^PSX(550.1,"
SET DR="1////5"
+36 LOCK +^PSX(550.1,PSXMSG):600
if '$TEST
QUIT
+37 DO ^DIE
LOCK -^PSX(550.1,PSXMSG)
KILL DA,DR,DIE
OERR ;clear ^XTMP("ORLK-" if it is CPRS/CMOP
+1 NEW ORD
SET ORD=+$PIECE($GET(^PSRX(+$GET(RX),"OR1")),"^",2)
+2 IF ORD
IF $DATA(^XTMP("ORLK-"_ORD,0))
IF ^XTMP("ORLK-"_ORD,0)["CPRS/CMOP"
KILL ^XTMP("ORLK-"_ORD)
+3 QUIT
PRINT DO NOW^%DTC
SET DTTM=%
SET COM="CMOP Suspense Label "_$SELECT($GET(^PS(52.5,REC,"P"))=0:"Printed",1:"RePrinted")_$SELECT($GET(^PSRX(PTR,"TYPE"))>0:" (PARTIAL)",1:"")
+1 SET CNT=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(PTR,"A",JJ))
if 'JJ
QUIT
SET CNT=JJ
+2 SET $PIECE(^PSRX(PTR,"STA"),"^",1)=0
SET ^PS(52.5,REC,"P")=1
+3 SET CNT=CNT+1
SET ^PSRX(PTR,"A",0)="^52.3DA^"_CNT_"^"_CNT
LOCK +^PSRX(PTR):600
if '$TEST
QUIT
SET ^PSRX(PTR,"A",CNT,0)=DTTM_"^S^"_DUZ_"^"_FILL_"^"_COM
LOCK -^PSRX(PTR)
+4 KILL DTTM,%,COM,CNT,JJ
+5 QUIT
SUSPS ;goes through the PS(550.1 file and gets the pointer for each rx in PSRX
+1 ;CMOP Event entry
+2 SET XXX=0
FOR
SET XXX=$ORDER(^PSX(550.1,REC,2,XXX))
if XXX'>0
QUIT
DO ACLOG
+3 KILL XXX
+4 QUIT
ACLOG ;
+1 DO NOW^%DTC
+2 SET PSXPTR=$PIECE($GET(^PSX(550.1,REC,2,XXX,0)),U,1)
+3 FOR RCC=0:0
SET RCC=$ORDER(^PSRX(+PSXPTR,4,"B",OLDBAT,RCC))
if RCC=""
QUIT
SET RC=RCC
+4 SET TRNN=$PIECE($GET(^PSRX(+PSXPTR,4,RC,0)),"^",1)
+5 SET FAC=$$GET1^DIQ(550.2,TRNN,3)
+6 SET FILL=$PIECE($GET(^PSRX(+PSXPTR,4,RC,0)),"^",3)
+7 SET CNT=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(+PSXPTR,"A",JJ))
if 'JJ
QUIT
SET CNT=JJ
+8 SET COMMENT="Retransmitted to "_FAC_" CMOP"
+9 SET CNT=CNT+1
SET ^PSRX(+PSXPTR,"A",0)="^52.3DA^"_CNT_"^"_CNT
+10 LOCK +^PSRX(+PSXPTR):600
if '$TEST
QUIT
+11 SET ^PSRX(+PSXPTR,"A",CNT,0)=%_U_"B"_U_DUZ_U_$SELECT(FILL>5:(FILL+1),1:FILL)_U_COMMENT
+12 LOCK -^PSRX(+PSXPTR)
+13 LOCK +^PSRX(+PSXPTR,4,0):600
if '$TEST
QUIT
+14 SET DA(1)=+PSXPTR
SET DIE="^PSRX("_+PSXPTR_",4,"
SET DA=RC
SET DR="3////2"
+15 DO ^DIE
KILL DIE,DA,DR,DD,DO
+16 if '$DATA(^PSRX(+PSXPTR,4,0))
SET ^PSRX(+PSXPTR,4,0)="^52.01DA^^"
+17 SET DA(1)=+PSXPTR
SET DIC="^PSRX("_+PSXPTR_",4,"
SET DIC(0)="Z"
SET X=PSXBAT
+18 SET DIC("DR")="1////"_REC_";2////"_$GET(FILL)_";3////0"
DO F
+19 LOCK -^PSRX(+PSXPTR,4,0)
+20 KILL PSXPTR,COMMENT,CNT,JJ,FILL,REF,%,DIC,DA,DIE,DR
+21 SET DA=REC
SET DIE="^PSX(550.1,"
SET DR="1////5"
LOCK +^PSX(550.1,REC):600
if '$TEST
QUIT
+22 DO ^DIE
LOCK -^PSX(550.1,REC)
KILL DIE,DA,DR,FAC,TRNN
+23 QUIT
RXERR ;auto error processing of RX updating 52 & 52.5
+1 SET XXERR=$$EC^%ZOSV
+2 SET PSXDIVNM=$$GET1^DIQ(59,PSOSITE,.01)
+3 ;save an image of the transient file 550.1 for 2 days
+4 DO NOW^%DTC
SET DTTM=%
+5 ;VMP OIFO BAY PINES;ELR;PSX*2*57 CHANE PURGE DATE TO T+12 FROM T+2
+6 SET X=$$FMADD^XLFDT(DT,+12)
SET ^XTMP("PSXERR "_DTTM,0)=X_U_DT_U_"CMOP "_XXERR
+7 MERGE ^XTMP("PSXERR "_DTTM,550.1)=^PSX(550.1)
+8 SET XMSUB="CMOP Error "_PSXDIVNM_" "_$$GET1^DIQ(550.2,+$GET(PSXBAT),.01)
+9 DO GRP1^PSXNOTE
+10 ;S XMY(DUZ)=""
+11 SET XMTEXT="TEXT("
+12 SET TEXT(1,0)=$SELECT($GET(PSXCS):"",1:"NON-")_"CS CMOP transmission encountered the following error. Please investigate"
+13 SET TEXT(2,0)="Division: "_PSXDIVNM
+14 SET TEXT(3,0)="Type/Batch "_$SELECT($GET(PSXCS):"CS",1:"NON-CS")_" / "_$$GET1^DIQ(550.2,$GET(PSXBAT),.01)
+15 SET TEXT(4,0)="Error: "_XXERR
+16 SET TEXT(5,0)=">>>This batch has been sent <<<"
+17 SET TEXT(6,0)="Call NVS to investigate which prescriptions have been updated"
+18 SET TEXT(7,0)="or not updated in files Prescription #52 & Suspense 52.5 ."
+19 SET TEXT(8,0)="A copy of file 550.1 can be found in ^XTMP(""PSXERR "_DTTM_""")"
+20 DO ^%ZTER
+21 DO ^XMD
+22 GOTO UNWIND^%ZTER
