Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSXRXU

PSXRXU.m

Go to the documentation of this file. 
  1. PSXRXU ;BIR/WPB,HTW,BAB-Remote Facility File Utilities ;14 Dec 2001
  1.  ;;2.0;CMOP;**3,28,41,57,48**;11 Apr 97
  1.  ; Reference to ^PS(52.5,  supported by DBIA #1978
  1.  ; Reference to ^PSOHLSN1  supported by DBIA #2385
  1.  ; Reference to ^PSRX(     supported by DBIA #1977
  1.  ; Reference to ^XTMP("ORLK-" supported by DBIA #4001
  1.  ; Reference to $$GETNDC^PSONDCUT supported by DBIA #4705
  1. START ;files transmission data in file 52 52.5 after transmission is sent
  1.  ; and clear OERR lock ^XTMP("ORLK-"
  1.  ; setup error trap for updating RXs in 52 & 52.5
  1.  D
  1.  . I '$D(^XTMP("PSXAUTOERR")) N $ETRAP,$ESTACK S $ETRAP="D RXERR^PSXRXU"
  1.  . D START1
  1.  Q
  1. START1 ;
  1.  S PSXNM="",PSXMSG=0
  1.  F  S PSXNM=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM)) Q:PSXNM']""  D
  1.  . S DFN="" F  S DFN=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN)) Q:DFN'>0  D
  1.  .. S RX=0,PSXMSG=PSXMSG+1 F  S RX=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX)) Q:RX'>0  D
  1.  ... S RXF=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX,0))
  1.  ... D FILE
  1.  Q
  1. F D FILE^DICN
  1.  Q
  1. FILE ;files the data in the CMOP event multiple of PSRX(
  1.  ;update 52, 52.5 called from PSXBLD RX loop
  1.  S FILL=+RXF
  1.  S:$G(PSXTDT)="" PSXTDT=$P(^PSX(550.2,PSXBAT,0),"^",6)
  1.  Q:'$D(^PSRX(RX,0))
  1.  ;S PSXMSG=$P(^PSX(550.1,XX,0),"^")
  1.  ; update RX, RX:CMOP multiple
  1.  ;If Rx status = suspended (5) set to active (0)
  1.  I $P(^PSRX(RX,"STA"),U,1)=5 S $P(^PSRX(RX,"STA"),U,1)=0
  1.  D EN^PSOHLSN1(RX,"SC","ZU","Transmitted to CMOP","")
  1.  S:'$D(^PSRX(RX,4,0)) ^PSRX(RX,4,0)="^52.01DA^^"
  1.  K DD,DO,DIE,DA,DIC,DR
  1.  ;VMP OIFO BAY PINES;ELR;PSX*2*57 REMOVE LOCK AND UNLOCK OF PSRX(4
  1.  ;L +^PSRX(RX,4,0):600 Q:'$T
  1.  S DA(1)=RX,DIC="^PSRX("_RX_",4,",DIC(0)="Z",X=PSXBAT
  1.  S DIC("DR")="1////"_$G(PSXMSG)_";2////"_$G(FILL)_";3////0;12///"_$S($$PATCH^XPDUTL("PSO*7.0*148"):$$GETNDC^PSONDCUT(RX,FILL),1:"")
  1.  D:'$D(^PSRX(RX,4,"B",PSXBAT)) FILE^DICN I 1
  1.  E  S DIE=DIC,DR=DIC("DR"),DA=$O(^PSRX(RX,4,"B",PSXBAT,0)) K DIC D ^DIE
  1.  K DIC,DA,DR,DIE
  1.  ;L -^PSRX(RX,4,0)
  1.  K FAC
  1.  S FAC=$$GET1^DIQ(550.2,PSXBAT,3)
  1.  S COM=$S($G(PSXRTRN):"Re-",1:"")_"Transmitted to "_FAC_" CMOP"
  1.  S:$G(FILL)>5 FILL=$G(FILL)+1
  1.  S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ  S CNT=JJ
  1.  S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
  1.  ;VMP OIFO BAY PINES;ELR;PSX*2*57 REMOVE LOCK AND UNLOCK OF PSRX
  1.  ;L +^PSRX(RX):600 Q:'$T
  1.  S ^PSRX(RX,"A",CNT,0)=PSXTDT_"^B^"_DUZ_"^"_$G(FILL)_"^"_COM
  1.  ;L -^PSRX(RX)
  1.  S IN525=$O(^PS(52.5,"B",RX,""))
  1.  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
  1.  K DIE,DR,DA
  1.  S DA=PSXMSG,DIE="^PSX(550.1,",DR="1////5"
  1.  L +^PSX(550.1,PSXMSG):600 Q:'$T
  1.  D ^DIE L -^PSX(550.1,PSXMSG) K DA,DR,DIE
  1. OERR ;clear ^XTMP("ORLK-" if it is CPRS/CMOP
  1.  N ORD S ORD=+$P($G(^PSRX(+$G(RX),"OR1")),"^",2)
  1.  I ORD,$D(^XTMP("ORLK-"_ORD,0)),^XTMP("ORLK-"_ORD,0)["CPRS/CMOP" K ^XTMP("ORLK-"_ORD)
  1.  Q
  1. 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:"")
  1.  S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(PTR,"A",JJ)) Q:'JJ  S CNT=JJ
  1.  S $P(^PSRX(PTR,"STA"),"^",1)=0,^PS(52.5,REC,"P")=1
  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)
  1.  K DTTM,%,COM,CNT,JJ
  1.  Q
  1. SUSPS ;goes through the PS(550.1 file and gets the pointer for each rx in PSRX
  1.  ;CMOP Event entry
  1.  S XXX=0 F  S XXX=$O(^PSX(550.1,REC,2,XXX)) Q:XXX'>0  D ACLOG
  1.  K XXX
  1.  Q
  1. ACLOG ;
  1.  D NOW^%DTC
  1.  S PSXPTR=$P($G(^PSX(550.1,REC,2,XXX,0)),U,1)
  1.  F RCC=0:0 S RCC=$O(^PSRX(+PSXPTR,4,"B",OLDBAT,RCC)) Q:RCC=""  S RC=RCC
  1.  S TRNN=$P($G(^PSRX(+PSXPTR,4,RC,0)),"^",1)
  1.  S FAC=$$GET1^DIQ(550.2,TRNN,3)
  1.  S FILL=$P($G(^PSRX(+PSXPTR,4,RC,0)),"^",3)
  1.  S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(+PSXPTR,"A",JJ)) Q:'JJ  S CNT=JJ
  1.  S COMMENT="Retransmitted to "_FAC_" CMOP"
  1.  S CNT=CNT+1,^PSRX(+PSXPTR,"A",0)="^52.3DA^"_CNT_"^"_CNT
  1.  L +^PSRX(+PSXPTR):600 Q:'$T
  1.  S ^PSRX(+PSXPTR,"A",CNT,0)=%_U_"B"_U_DUZ_U_$S(FILL>5:(FILL+1),1:FILL)_U_COMMENT
  1.  L -^PSRX(+PSXPTR)
  1.  L +^PSRX(+PSXPTR,4,0):600 Q:'$T
  1.  S DA(1)=+PSXPTR,DIE="^PSRX("_+PSXPTR_",4,",DA=RC,DR="3////2"
  1.  D ^DIE K DIE,DA,DR,DD,DO
  1.  S:'$D(^PSRX(+PSXPTR,4,0)) ^PSRX(+PSXPTR,4,0)="^52.01DA^^"
  1.  S DA(1)=+PSXPTR,DIC="^PSRX("_+PSXPTR_",4,",DIC(0)="Z",X=PSXBAT
  1.  S DIC("DR")="1////"_REC_";2////"_$G(FILL)_";3////0" D F
  1.  L -^PSRX(+PSXPTR,4,0)
  1.  K PSXPTR,COMMENT,CNT,JJ,FILL,REF,%,DIC,DA,DIE,DR
  1.  S DA=REC,DIE="^PSX(550.1,",DR="1////5" L +^PSX(550.1,REC):600 Q:'$T
  1.  D ^DIE L -^PSX(550.1,REC) K DIE,DA,DR,FAC,TRNN
  1.  Q
  1. RXERR ;auto error processing of RX updating 52 & 52.5
  1.  S XXERR=$$EC^%ZOSV
  1.  S PSXDIVNM=$$GET1^DIQ(59,PSOSITE,.01)
  1.  ;save an image of the transient file 550.1 for 2 days
  1.  D NOW^%DTC S DTTM=%
  1.  ;VMP OIFO BAY PINES;ELR;PSX*2*57 CHANE PURGE DATE TO T+12 FROM T+2
  1.  S X=$$FMADD^XLFDT(DT,+12) S ^XTMP("PSXERR "_DTTM,0)=X_U_DT_U_"CMOP "_XXERR
  1.  M ^XTMP("PSXERR "_DTTM,550.1)=^PSX(550.1)
  1.  S XMSUB="CMOP Error "_PSXDIVNM_" "_$$GET1^DIQ(550.2,+$G(PSXBAT),.01)
  1.  D GRP1^PSXNOTE
  1.  ;S XMY(DUZ)=""
  1.  S XMTEXT="TEXT("
  1.  S TEXT(1,0)=$S($G(PSXCS):"",1:"NON-")_"CS CMOP transmission encountered the following error. Please investigate"
  1.  S TEXT(2,0)="Division:         "_PSXDIVNM
  1.  S TEXT(3,0)="Type/Batch        "_$S($G(PSXCS):"CS",1:"NON-CS")_" / "_$$GET1^DIQ(550.2,$G(PSXBAT),.01)
  1.  S TEXT(4,0)="Error:            "_XXERR
  1.  S TEXT(5,0)=">>>This batch has been sent <<<"
  1.  S TEXT(6,0)="Call NVS to investigate which prescriptions have been updated"
  1.  S TEXT(7,0)="or not updated in files Prescription #52 & Suspense 52.5 ."
  1.  S TEXT(8,0)="A copy of file 550.1 can be found in ^XTMP(""PSXERR "_DTTM_""")"
  1.  D ^%ZTER
  1.  D ^XMD
  1.  G UNWIND^%ZTER