PSXRECV ;BIR/WPB-Downloads Data from Mailman Msg to Files ;04/08/97 2:06 PM
;;2.0;CMOP;**34,38,45**;11 Apr 97
HDR S (PSXORDCT,PSXSMSG,PSXRTRN,PSXRXS)=0,ZTREQ="@"
K DD,DO,^TMP($J,"PSXREV") S PSXXMRG=XMRG
S PSXBAT=$P($G(XMRG),U,2),PSXSITE=$P($G(XMRG),U,3),PSXSYST=$P(XMRG,U,4),SDATE=$P($G(XMRG),U,6)
S SITEN=$P($G(XMRG),U,5)
S PSXREF=SITEN_"-"_PSXBAT,PSXSTART=$P(XMRG,U,8),PSXFROM=XMFROM
S PSXSENDR=$P(XMRG,U,7),PSXLAST=$P(XMRG,U,9),PSXDIV=$P(XMRG,U,10),XSITE=$P(XMRG,U,11),XMSER="S."_XQSOP,TXMZ=XQMSG
;S X=SITEN,DIC="4",DIC(0)="MOXZ" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S SITENUM=+Y K DIC,Y,X ;****DOD L1
S X=SITEN,AGNCY="VASTANUM" S:$D(^PSX(552,"D",X)) X=$E(X,2,99),AGNCY="DMIS" S SITENUM=$$IEN^XUMF(4,AGNCY,X) K DIC,Y,X,AGNCY ;****DOD L1
S OLDBAT=$P($G(XMRG),U,12) I OLDBAT'="" S PSXRTRN=1,PSXOLD=SITEN_"-"_OLDBAT
G:$G(SITENUM)="" EXIT1
S XXR=$O(^PSX(552,"B",$G(SITENUM),""))
G:'$D(^PSX(552,"C",$G(XXR))) EXIT1
S:$G(^XMB(3.9,TXMZ,0))["CMOP Controlled Substances Transmission" CSB=1
I $G(CSB)=1 N X S X=$$FMADD^XLFDT(DT,+3),^XTMP("PSXCS",PSXREF)=X_U_DT_U_"CS TRANSMISSION" K X
;this would be a good place to send an alert or mail message if the
;transmitting site was not active in the CMOP files
I $G(XMFROM)["@" S DOMAIN=$P($G(XMFROM),"@",2)
I $G(XMFROM)'["@" S DOMAIN=""
S DOMAIN=""
S SAME=$O(^PSX(552.1,"B",PSXREF,"")) S:$G(SAME)'="" PSXRTRN=2 D:$G(SAME)'="" CHKDUP^PSXRECV1 G:$G(FLAG5)>0 EXIT
I PSXRTRN=1 S RR=$O(^PSX(552.1,"B",PSXOLD,"")) D
.Q:$G(RR)'>0
.S OLDSDT=$P(^PSX(552.1,RR,0),U,4)
.S CHK=$P($G(^PSX(552.1,RR,0)),U,2) D
.S:$G(CHK)=3 PSXFLG1=2
.I (CHK=2)!(CHK=1) S PSXJOB=""
.;I CHK="" S PSXJOB=2,PSXERR=2_"^"_2 D ^PSXERR Q
.;I (CHK=3)!(CHK=4) S PSXJOB=2,PSXERR=2_"^"_CHK D ^PSXERR Q
.;I CHK=5 S PSXJOB=2,PSXERR=2_"^"_CHK
STRT I PSXRTRN=1,($G(RR)'=""),($P(^PSX(552.1,$G(RR),0),"^",2)=2) L +^PSX(552.1,$G(RR)):600 G:'$T EXIT S $P(^PSX(552.1,RR,0),"^",2)=5 S DA=RR,DIK="^PSX(552.1," D IX^DIK K DA,DIK L -^PSX(552.1,$G(RR))
S:$D(^PSX(552.1,"ART",$G(PSXREF))) PSXRTRN=3
S X=PSXREF,DIC="^PSX(552.1,",DIC(0)="Z"
S DIC("DR")="1////"_$S(PSXRTRN<1:"1",PSXRTRN>0:"5",1:"")_";2////"_PSXDIV_";3////"_XSITE_";4////"_PSXSENDR_";5////"_SDATE_";8////"_PSXSTART_";9////"_PSXLAST_$S(PSXRTRN=1:";13////"_PSXOLD_";12////1",1:"")_";21////"_$G(CSB)
D F K DIC,X,DA,CSB S (OLDDA,PSXDA)=+Y
I '$D(^PSX(552.4,"B",PSXDA)) K DD,DO S X=PSXDA,DIC(0)="Z",DIC="^PSX(552.4," D F S DA515=+Y
F X XMREC G:$G(XMER)<0 EX^PSXSERV D:$E(XMRG,1,6)["NTE|1|" SITE Q:$E(XMRG,1,5)["$$END" G:$E(XMRG,1,4)["$MSG" MSG
K XMER,XMREC,XMRG
G EXIT
Q
F D FILE^DICN Q
SITE S ^PSX(552.1,PSXDA,"S",0)="^552.114A^^"
K DO,DD
L +^PSX(552.1,PSXDA,"S"):600 G:'$T EXIT
S X=XMRG,DA(1)=PSXDA,DIC="^PSX(552.1,"_PSXDA_",""S"",",DIC(0)="Z" D F
F X XMREC G:$E(XMRG,1,4)["$MSG" MSG G:$E(XMRG,1,9)["$$END" EXIT S X=XMRG,DA(1)=PSXDA,DIC="^PSX(552.1,"_PSXDA_",""S"",",DIC(0)="Z" D F K DA,DIC,X
L -^PSX(552.1,PSXDA,"S")
Q
MSG S PSXORDCT=PSXORDCT+1
K DD,DO,PSXMSG,LNCNT,PSXDA
S I=1,PSXMSG=$P(XMRG,U,2),(X,PSXID)=PSXREF_"-"_PSXMSG S:PSXSMSG=0 PSXSMSG=PSXMSG S DIC="^PSX(552.2,",DIC(0)="Z",DIC("DR")="1////4;2////"_$H D F S PSXDA=+Y
S ^PSX(552.2,PSXDA,"T",0)="^552.27A^^"
F X XMREC G:$E(XMRG,1,4)["$MSG" QUE S:$E(XMRG,1,4)["MSH|" $P(XMRG,"|",10)=PSXID S:$E(XMRG,1,7)["ORC|NW" PSXRXS=PSXRXS+1 D:$E(XMRG,1,4)["RX1|" RX1 D:$E(XMRG,1,4)["ZX1|" ZX1 D:$E(XMRG,1,4)["PID|" PID G:$E(XMRG,1,9)["$$END" QUE D
.L +^PSX(552.2,PSXDA):30 S ^PSX(552.2,PSXDA,"T",I,0)=$G(XMRG) L -^PSX(552.2,PSXDA) S $P(^PSX(552.2,PSXDA,"T",0),U,3)=I,$P(^(0),U,4)=I,I=I+1 I $E(XMRG,1,4)["ZX1|" S DA(1)=PSXDA,(SUBDA,DA)=I-1,DIK="^PSX(552.2,"_PSXDA_",""T""," D IX^DIK K DA,DIK
Q
PID I $E(XMRG,1,4)["PID|" S NAME=$P(XMRG,"|",6),NAME=$TR(NAME,"^",",") Q
RX1 I $E(XMRG,1,4)["RX1|" S RXNDX=$P(XMRG,"|",2),DRG515=$P($P(XMRG,"|",15),"^",1),QTY515=$P(XMRG,"|",13),PSXDRG=$P(XMRG,U,2)
S FL515=(+$P($P(XMRG,"|",2),"-",3)-1)
Q
ZX1 I $E(XMRG,1,4)["ZX1|" S RX515=$P(XMRG,"|",2),PSXCS=$P($G(XMRG),"|",15) D F515^PSXRECV1
Q
QUE L +^PSX(552.2,PSXDA):600 G:'$T EXIT
S DA=PSXDA,DIE="^PSX(552.2,",DR="1////1;2////"_$H D ^DIE K DA,DIE,DR
L -^PSX(552.2,PSXDA)
I $E(XMRG,1,9)["$$END" G UPDATE^PSXRECV1
G MSG
;
EXIT S XMZ=TXMZ,XMSER="S.PSXX CMOP SERVER" D REMSBMSG^XMA1C
EXIT1 I $G(OLDDA)'="" S DA=OLDDA,DIK="^PSX(552.1," D IX^DIK K DA,DIK
I $G(SAME)'="" S DA=SAME,DIK="^PSX(552.1," D IX^DIK K DA,DIK
K PSXSTART,PSXEND,PSXRXCT,PSXMSGCT,PSXSMSG,PSXLAST,PSXRXS,PSXORDCT,PSXSITE,PSXTDT,PSXFTDT,%,DOMAIN,PSXFLAG,I,OLDDA,PSXID,PSXSENDR,PSXREF,PSXMSG,PSXBAT,SDATE,SDT,SUBDA,PSXSYST,X,Y,XMFROM,SITENUM
K XMSER,XQMSG,XQSOP,OLDBAT,XMZ,PSXDIV,XSITE,CHK,REC,RR,RRR,SITEN,PSXJOB,PSXERR,PSXFROM,PSXOLD,PSXRTRN,XXR,DA515,DRG515,FL515,QTY515,RX515,SAME,OLDSDT,OLDTM,PSXDRG,NAME,NAME1,FLAG5,PSXXMGR
K NM5521,RXNDX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXRECV 4826 printed Dec 13, 2024@01:44:48 Page 2
PSXRECV ;BIR/WPB-Downloads Data from Mailman Msg to Files ;04/08/97 2:06 PM
+1 ;;2.0;CMOP;**34,38,45**;11 Apr 97
HDR SET (PSXORDCT,PSXSMSG,PSXRTRN,PSXRXS)=0
SET ZTREQ="@"
+1 KILL DD,DO,^TMP($JOB,"PSXREV")
SET PSXXMRG=XMRG
+2 SET PSXBAT=$PIECE($GET(XMRG),U,2)
SET PSXSITE=$PIECE($GET(XMRG),U,3)
SET PSXSYST=$PIECE(XMRG,U,4)
SET SDATE=$PIECE($GET(XMRG),U,6)
+3 SET SITEN=$PIECE($GET(XMRG),U,5)
+4 SET PSXREF=SITEN_"-"_PSXBAT
SET PSXSTART=$PIECE(XMRG,U,8)
SET PSXFROM=XMFROM
+5 SET PSXSENDR=$PIECE(XMRG,U,7)
SET PSXLAST=$PIECE(XMRG,U,9)
SET PSXDIV=$PIECE(XMRG,U,10)
SET XSITE=$PIECE(XMRG,U,11)
SET XMSER="S."_XQSOP
SET TXMZ=XQMSG
+6 ;S X=SITEN,DIC="4",DIC(0)="MOXZ" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S SITENUM=+Y K DIC,Y,X ;****DOD L1
+7 ;****DOD L1
SET X=SITEN
SET AGNCY="VASTANUM"
if $DATA(^PSX(552,"D",X))
SET X=$EXTRACT(X,2,99)
SET AGNCY="DMIS"
SET SITENUM=$$IEN^XUMF(4,AGNCY,X)
KILL DIC,Y,X,AGNCY
+8 SET OLDBAT=$PIECE($GET(XMRG),U,12)
IF OLDBAT'=""
SET PSXRTRN=1
SET PSXOLD=SITEN_"-"_OLDBAT
+9 if $GET(SITENUM)=""
GOTO EXIT1
+10 SET XXR=$ORDER(^PSX(552,"B",$GET(SITENUM),""))
+11 if '$DATA(^PSX(552,"C",$GET(XXR)))
GOTO EXIT1
+12 if $GET(^XMB(3.9,TXMZ,0))["CMOP Controlled Substances Transmission"
SET CSB=1
+13 IF $GET(CSB)=1
NEW X
SET X=$$FMADD^XLFDT(DT,+3)
SET ^XTMP("PSXCS",PSXREF)=X_U_DT_U_"CS TRANSMISSION"
KILL X
+14 ;this would be a good place to send an alert or mail message if the
+15 ;transmitting site was not active in the CMOP files
+16 IF $GET(XMFROM)["@"
SET DOMAIN=$PIECE($GET(XMFROM),"@",2)
+17 IF $GET(XMFROM)'["@"
SET DOMAIN=""
+18 SET DOMAIN=""
+19 SET SAME=$ORDER(^PSX(552.1,"B",PSXREF,""))
if $GET(SAME)'=""
SET PSXRTRN=2
if $GET(SAME)'=""
DO CHKDUP^PSXRECV1
if $GET(FLAG5)>0
GOTO EXIT
+20 IF PSXRTRN=1
SET RR=$ORDER(^PSX(552.1,"B",PSXOLD,""))
Begin DoDot:1
+21 if $GET(RR)'>0
QUIT
+22 SET OLDSDT=$PIECE(^PSX(552.1,RR,0),U,4)
+23 SET CHK=$PIECE($GET(^PSX(552.1,RR,0)),U,2)
Begin DoDot:2
End DoDot:2
+24 if $GET(CHK)=3
SET PSXFLG1=2
+25 IF (CHK=2)!(CHK=1)
SET PSXJOB=""
+26 ;I CHK="" S PSXJOB=2,PSXERR=2_"^"_2 D ^PSXERR Q
+27 ;I (CHK=3)!(CHK=4) S PSXJOB=2,PSXERR=2_"^"_CHK D ^PSXERR Q
+28 ;I CHK=5 S PSXJOB=2,PSXERR=2_"^"_CHK
End DoDot:1
STRT IF PSXRTRN=1
IF ($GET(RR)'="")
IF ($PIECE(^PSX(552.1,$GET(RR),0),"^",2)=2)
LOCK +^PSX(552.1,$GET(RR)):600
if '$TEST
GOTO EXIT
SET $PIECE(^PSX(552.1,RR,0),"^",2)=5
SET DA=RR
SET DIK="^PSX(552.1,"
DO IX^DIK
KILL DA,DIK
LOCK -^PSX(552.1,$GET(RR))
+1 if $DATA(^PSX(552.1,"ART",$GET(PSXREF)))
SET PSXRTRN=3
+2 SET X=PSXREF
SET DIC="^PSX(552.1,"
SET DIC(0)="Z"
+3 SET DIC("DR")="1////"_$SELECT(PSXRTRN<1:"1",PSXRTRN>0:"5",1:"")_";2////"_PSXDIV_";3////"_XSITE_";4////"_PSXSENDR_";5////"_SDATE_";8////"_PSXSTART_";9////"_PSXLAST_$SELECT(PSXRTRN=1:";13////"_PSXOLD_";12////1",1:"")_";21////"_$GET(CSB)
+4 DO F
KILL DIC,X,DA,CSB
SET (OLDDA,PSXDA)=+Y
+5 IF '$DATA(^PSX(552.4,"B",PSXDA))
KILL DD,DO
SET X=PSXDA
SET DIC(0)="Z"
SET DIC="^PSX(552.4,"
DO F
SET DA515=+Y
+6 FOR
XECUTE XMREC
if $GET(XMER)<0
GOTO EX^PSXSERV
if $EXTRACT(XMRG,1,6)["NTE|1|"
DO SITE
if $EXTRACT(XMRG,1,5)["$$END"
QUIT
if $EXTRACT(XMRG,1,4)["$MSG"
GOTO MSG
+7 KILL XMER,XMREC,XMRG
+8 GOTO EXIT
+9 QUIT
F DO FILE^DICN
QUIT
SITE SET ^PSX(552.1,PSXDA,"S",0)="^552.114A^^"
+1 KILL DO,DD
+2 LOCK +^PSX(552.1,PSXDA,"S"):600
if '$TEST
GOTO EXIT
+3 SET X=XMRG
SET DA(1)=PSXDA
SET DIC="^PSX(552.1,"_PSXDA_",""S"","
SET DIC(0)="Z"
DO F
+4 FOR
XECUTE XMREC
if $EXTRACT(XMRG,1,4)["$MSG"
GOTO MSG
if $EXTRACT(XMRG,1,9)["$$END"
GOTO EXIT
SET X=XMRG
SET DA(1)=PSXDA
SET DIC="^PSX(552.1,"_PSXDA_",""S"","
SET DIC(0)="Z"
DO F
KILL DA,DIC,X
+5 LOCK -^PSX(552.1,PSXDA,"S")
+6 QUIT
MSG SET PSXORDCT=PSXORDCT+1
+1 KILL DD,DO,PSXMSG,LNCNT,PSXDA
+2 SET I=1
SET PSXMSG=$PIECE(XMRG,U,2)
SET (X,PSXID)=PSXREF_"-"_PSXMSG
if PSXSMSG=0
SET PSXSMSG=PSXMSG
SET DIC="^PSX(552.2,"
SET DIC(0)="Z"
SET DIC("DR")="1////4;2////"_$HOROLOG
DO F
SET PSXDA=+Y
+3 SET ^PSX(552.2,PSXDA,"T",0)="^552.27A^^"
+4 FOR
XECUTE XMREC
if $EXTRACT(XMRG,1,4)["$MSG"
GOTO QUE
if $EXTRACT(XMRG,1,4)["MSH|"
SET $PIECE(XMRG,"|",10)=PSXID
if $EXTRACT(XMRG,1,7)["ORC|NW"
SET PSXRXS=PSXRXS+1
if $EXTRACT(XMRG,1,4)["RX1|"
DO RX1
if $EXTRACT(XMRG,1,4)["ZX1|"
DO ZX1
if $EXTRACT(XMRG,1,4)["PID|"
DO PID
if $EXTRACT(XMRG,1,9)["$$END"
GOTO QUE
Begin DoDot:1
+5 LOCK +^PSX(552.2,PSXDA):30
SET ^PSX(552.2,PSXDA,"T",I,0)=$GET(XMRG)
LOCK -^PSX(552.2,PSXDA)
SET $PIECE(^PSX(552.2,PSXDA,"T",0),U,3)=I
SET $PIECE(^(0),U,4)=I
SET I=I+1
IF $EXTRACT(XMRG,1,4)["ZX1|"
SET DA(1)=PSXDA
SET (SUBDA,DA)=I-1
SET DIK="^PSX(552.2,"_PSXDA_",""T"","
DO IX^DIK
KILL DA,DIK
End DoDot:1
+6 QUIT
PID IF $EXTRACT(XMRG,1,4)["PID|"
SET NAME=$PIECE(XMRG,"|",6)
SET NAME=$TRANSLATE(NAME,"^",",")
QUIT
RX1 IF $EXTRACT(XMRG,1,4)["RX1|"
SET RXNDX=$PIECE(XMRG,"|",2)
SET DRG515=$PIECE($PIECE(XMRG,"|",15),"^",1)
SET QTY515=$PIECE(XMRG,"|",13)
SET PSXDRG=$PIECE(XMRG,U,2)
+1 SET FL515=(+$PIECE($PIECE(XMRG,"|",2),"-",3)-1)
+2 QUIT
ZX1 IF $EXTRACT(XMRG,1,4)["ZX1|"
SET RX515=$PIECE(XMRG,"|",2)
SET PSXCS=$PIECE($GET(XMRG),"|",15)
DO F515^PSXRECV1
+1 QUIT
QUE LOCK +^PSX(552.2,PSXDA):600
if '$TEST
GOTO EXIT
+1 SET DA=PSXDA
SET DIE="^PSX(552.2,"
SET DR="1////1;2////"_$HOROLOG
DO ^DIE
KILL DA,DIE,DR
+2 LOCK -^PSX(552.2,PSXDA)
+3 IF $EXTRACT(XMRG,1,9)["$$END"
GOTO UPDATE^PSXRECV1
+4 GOTO MSG
+5 ;
EXIT SET XMZ=TXMZ
SET XMSER="S.PSXX CMOP SERVER"
DO REMSBMSG^XMA1C
EXIT1 IF $GET(OLDDA)'=""
SET DA=OLDDA
SET DIK="^PSX(552.1,"
DO IX^DIK
KILL DA,DIK
+1 IF $GET(SAME)'=""
SET DA=SAME
SET DIK="^PSX(552.1,"
DO IX^DIK
KILL DA,DIK
+2 KILL PSXSTART,PSXEND,PSXRXCT,PSXMSGCT,PSXSMSG,PSXLAST,PSXRXS,PSXORDCT,PSXSITE,PSXTDT,PSXFTDT,%,DOMAIN,PSXFLAG,I,OLDDA,PSXID,PSXSENDR,PSXREF,PSXMSG,PSXBAT,SDATE,SDT,SUBDA,PSXSYST,X,Y,XMFROM,SITENUM
+3 KILL XMSER,XQMSG,XQSOP,OLDBAT,XMZ,PSXDIV,XSITE,CHK,REC,RR,RRR,SITEN,PSXJOB,PSXERR,PSXFROM,PSXOLD,PSXRTRN,XXR,DA515,DRG515,FL515,QTY515,RX515,SAME,OLDSDT,OLDTM,PSXDRG,NAME,NAME1,FLAG5,PSXXMGR
+4 KILL NM5521,RXNDX
+5 QUIT
