- 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
- 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
