- PRCFARR ;ISC-SF/TKW/LKG-BUILD RECEIVING REPORT FOR ELECTRONIC TRANSMISSION TO AUSTIN ;11/22/95 12:15
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ENRT ;RE-TRANSMIT RR ON DEMAND
- S DIC="^PRC(442,",DIC(0)="AEQM",DIC("S")="I $O(^PRC(442,+Y,11,0))" D ^DIC K DIC G:Y=-1 EX^PRCFARR3 S PRCFPO=+Y
- S DIC="^PRC(442,"_PRCFPO_",11,",DA(1)=PRCFPO,DIC(0)="AEQM",DIC("S")="I $P(^(0),""^"",19)'=""""" D ^DIC K DIC G:Y=-1 EX^PRCFARR3 S PRCFPR=+Y
- EN ; ENTRY POINT FOR AUTOMATIC TRANSMISSION
- K ^TMP("PRCFARR",$J) N D0
- Q:'$D(PRCFPO)!('$D(PRCFPR)) Q:'$D(^PRC(442,+PRCFPO,0))
- S PRCF0=^PRC(442,PRCFPO,0),PRCF1=$G(^(1)),PRCF12=$G(^(12)),PRCF17=$G(^(17)),PRCF18=$G(^(18)),PRCF11=^PRC(442,PRCFPO,11,PRCFPR,0),PRCFPRD=+PRCF11
- S PRCF10=$G(^PRC(442,PRCFPO,10,1,0)),PRCFTC=$S(PRCF10]"":$P($P(PRCF10,U),"."),1:"")
- S:PRCFTC'?2U PRCFTC=$S($P(PRCF0,U,2)=2:"SO",1:"MO")
- S PRCFOBNO=$TR($P(PRCF0,U),"-"),PRCFOBNO=PRCFOBNO_$E(" ",1,11-$L(PRCFOBNO))
- N FED,STA,FCP,DFY,BBFY,P2237,REQ,NET S STA=+PRCF0,FCP=+$P(PRCF0,U,3)
- S P2237=$P(PRCF0,U,12),DFY=$S(P2237?1.N:$P($P($G(^PRCS(410,P2237,0)),U),"-",2),1:""),REQ=""
- S BBFY=$P($G(^PRC(442,PRCFPO,23)),U,2) S:BBFY BBFY=1700+$E(BBFY,1,3)
- I STA,DFY,FCP,'BBFY S BBFY=$$BBFY^PRCSUT(STA,DFY,FCP)
- I STA,FCP,DFY,BBFY S REQ=$$ACC^PRC0C(STA,FCP_U_DFY_U_BBFY)
- S NET=1 I $P(REQ,U,12)="G" S NET=0
- N PRCACT,PRCFBNO S PRCACT="E",PRCFBNO="",LCKFLG=0
- I +$P(PRCF11,U,3)<0!(+$P(PRCF11,U,5)<0) D Q:LCKFLG
- . S PRCACT="M" D GETBN(+PRCF0,.PRCFBNO) Q:LCKFLG
- . S:$P(^PRC(442,PRCFPO,11,PRCFPR,0),U,20)="" $P(^(0),U,20)=PRCFBNO
- . S PRCFBNO=+PRCF0_$E(1000+PRCFBNO,2,4)
- I $P(PRCF0,"^",8),$P(PRCF0,"^",8)<$P(PRCF0,"^",6) S $P(PRCF0,"^",6,9)=$P(PRCF0,"^",8,9)_"^"_$P(PRCF0,"^",6,7)
- I '$D(PRCFJDN) S X=$P(PRCF1,"^",15) D JDN^PRCUTL S PRCFJDN=Y
- ;N PNO S PNO="00"_PRCFPR,PNO=$E(PNO,$L(PNO)-1,$L(PNO)) ; Partial #
- N PNO S PNO="" S X=$S(PRCACT="M"&($P($G(^PRC(442,PRCFPO,11,PRCFPR,1)),U,16)?1.N):$P(^(1),U,16),1:PRCFPR)
- D ALPHA^PRCFPAR(X,.PNO) ; IFCAP ==> FMS Partial #
- I PNO<0 D G EX^PRCFARR3
- . S X="Partial # is out of limits - FMS will not process.*"
- . D MSG^PRCFQ
- . Q
- S FED=0 I $P(PRCF1,U,7)]"","13578"[$P(PRCF1,U,7) S FED=2
- N SPLIT S SPLIT=$S(FED:"A",1:" ")
- S:FED AGYCD=$P(^PRCD(420.8,$P(PRCF1,U,7),0),U,5)
- N SEC1 S SEC1=$E($$SEC1^PRC0C(PRC("SITE"))_" ",1,4)
- S1 ;#1 SPLIT,STATION,PAT,PARTIAL NO.,PARTIAL DATE,JULIAN DATE,LINE/ITEM COUNT,CASCA PROJECT #,TRANS TYPE,SEC1,BATCH#,REF TRANS CODE & #,DOC ACTION
- S TMP=SPLIT_"^1^"_+PRCF0_"^"_$P($P(PRCF0,"^",1),"-",2)_"^"_PNO_"^"_$E(PRCF11,4,7)_$E(PRCF11,2,3)_"^"_$P(PRCF0,"^",14)_"^"
- S:FED TMP=TMP_AGYCD_U_PRCFJDN_U_$P(PRCF18,U,13)_U_$P(PRCF18,U,14)_U
- S TMP=TMP_SEC1_U_PRCFBNO_U_PRCFTC_U_PRCFOBNO_U_PRCACT_U_"001"_U
- S ^TMP("PRCFARR",$J,1,0)=TMP
- S2 ;#2 VENDOR NAME, ADDRESS, PHONE
- S PRCFX="",X=$G(^PRC(440,+PRCF1,0)),$P(PRCFX,"^",1,6)="2^"_$P(X,"^",1,5),$P(PRCFX,"^",7)=$E($P(X,"^",6),1,19)_" "_$S($D(^DIC(5,+$P(X,"^",7),0)):$P(^(0),"^",2),1:"")_" "_$P(X,"^",8),$P(PRCFX,"^",8)=$E($P(X,"^",10),1,18)
- N VN S VN=$P(PRCFX,U,2),$P(PRCFX,U,2)=$E(VN,1,30)
- S ^TMP("PRCFARR",$J,2,0)=PRCFX_"^"
- S3 ;#3 SHIP TO ADDRESS
- S D0=PRCFPO,(X,PRCFX)=""
- I +$P(PRCF0,"^",2)'=4 D
- . S PRC("SITE")=+PRCF0 D FTYP^PRCHFPNT
- . S X=$S($P($G(^PRC(442,PRCFPO,23)),U,7)]"":$P(^(23),U,7),1:+PRCF0)
- . S X=$S($D(^PRC(411,X,1,+$P(PRCF1,"^",3),0)):^(0),1:"")
- . S:X]"" $P(X,"^")=$P(X,"^")_"^"_$E(PRCHFTYP,1,24)
- I +$P(PRCF0,"^",2)=4,$P(PRCF1,"^",12)]"" S X=$S($D(^PRC(440.2,$P(PRCF1,"^",12),0)):^(0),1:"") S:X]"" $P(X,"^")=$S($D(^DPT(+X,0)):$E($P(^(0),"^",1),1,21),1:+X),$P(X,"^",4)=$P(X,"^",4)_"^"
- S $P(PRCFX,"^",1,6)="3^"_$E($P(X,"^",1),1,30)_"^"_$P(X,"^",2,5),$P(PRCFX,"^",7)=$P(X,"^",6)_" "_$S($D(^DIC(5,+$P(X,"^",7),0)):$P(^(0),"^",2),1:"")_" "_$P(X,"^",8),^TMP("PRCFARR",$J,3,0)=PRCFX_"^"
- S4 ;#4 REQ.SERVICE,GBL#,TYPE OF ORDER,PROPOSAL,CONTRACT(S)
- S Y=$S($D(^PRCD(420.8,+$P(PRCF1,"^",7),0)):$P(^(0),"^"),1:""),Y=$S(Y=2:"P",Y?1"B":Y,1:"D")
- S Z="^^",(X,Z1)="" F I=1:1:3 S X=$O(^PRC(442,PRCFPO,2,"AC",X)) Q:X="" S:$O(^(X,0)) Z1=^($O(^(0))) S $P(Z,"^",I)=Z1_X,Z1=""
- S X=$S($D(^DIC(49,+$P(PRCF1,"^",2),0)):^(0),1:""),Z1=$S($P(X,"^",8)]"":"("_$P(X,"^",8)_")",1:""),X=$E($P(X,"^"),1,(30-$L(Z1)))_Z1,Z1=""
- S ^TMP("PRCFARR",$J,4,0)="4^"_X_"^"_$P(PRCF12,"^",7)_"^"_Y_"^"_$P(PRCF1,"^",8)_"^"_Z_"^",$P(^(0),U,9)=""
- G EN^PRCFARR0
- FAMT I 'X S X="" Q
- S X=$P(X,".")_$E($P(X,".",2)_"00",1,2) Q
- W1 W !!,"Receiving Report is incomplete. Cannot transmit!",$C(7) Q
- GETBN(PRCSTA,PRCX) ;Get Batch #
- N PRCFDA,X,Y
- I $P(^PRC(442,PRCFPO,11,PRCFPR,0),U,20)]"" S PRCX=$P(^(0),U,20) Q
- S X=PRCSTA_"-RRT-00",DIC=422.2,DIC(0)="XL",DLAYGO=422.2 D ^DIC K DIC,DLAYGO
- I +Y<1 S PRCX=-1 Q
- S PRCFDA=+Y
- I $G(PRCFA8)=1 D LOCK KILL PRCFA8 QUIT
- D LOCK1 QUIT
- ;
- LOCK ;Process Receiving Report Option.
- L +^PRCF(422.2,PRCFDA):3
- E D Q:LCKFLG
- . S LCKFLG=1
- . DO EN^DDIOL("Record in use please try later.") Q
- ;
- I +$P(Y,U,3) S $P(^PRCF(422.2,PRCFDA,0),U,2)=500
- S PRCX=$P($G(^PRCF(422.2,PRCFDA,0)),U,2)+1
- S:PRCX>999 PRCX=1 S $P(^PRCF(422.2,PRCFDA,0),U,2)=PRCX
- L -^PRCF(422.2,PRCFDA)
- Q
- ;
- LOCK1 ;Get LOCK for tasked process. If unable to obtain a LOCK
- ;after 5 minutes (300 seconds) exit and give the user an email.
- L +^PRCF(422.2,PRCFDA):300
- E D LCKMSG S LCKFLG=1 Q
- ;
- I +$P(Y,U,3) S $P(^PRCF(422.2,PRCFDA,0),U,2)=500
- S PRCX=$P($G(^PRCF(422.2,PRCFDA,0)),U,2)+1
- S:PRCX>999 PRCX=1 S $P(^PRCF(422.2,PRCFDA,0),U,2)=PRCX
- L -^PRCF(422.2,PRCFDA)
- Q
- ;
- LCKMSG ;Send user a message
- N XMDUZ,MSG,MSG1
- S MSG="Error: Receiving Report NOT queued, "
- S MSG=MSG_"unable to obtain the batch transaction "
- S MSG1=" number. Please try again."
- K ^TMP("PRCFARR",$J)
- S ^TMP("PRCFARR",$J,1,0)=MSG
- S ^TMP("PRCFARR",$J,2,0)=MSG1
- S XMDUZ=$S($D(DUZ)#2:DUZ,1:.5)
- S XMY(XMDUZ)=""
- S XMSUB="RECEIVING REPORT "_$P(^PRC(442,PRCFA("PODA"),0),"^",1)
- S XMSUB=XMSUB_" PARTIAL #: "_PRCFA("PARTIAL")
- S XMTEXT="^TMP(""PRCFARR"","_$J_","
- S XMY(XMDUZ)=""
- D ^XMD
- K ^TMP("PRCFARR",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFARR 6061 printed Feb 18, 2025@23:28:51 Page 2
- PRCFARR ;ISC-SF/TKW/LKG-BUILD RECEIVING REPORT FOR ELECTRONIC TRANSMISSION TO AUSTIN ;11/22/95 12:15
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- ENRT ;RE-TRANSMIT RR ON DEMAND
- +1 SET DIC="^PRC(442,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $O(^PRC(442,+Y,11,0))"
- DO ^DIC
- KILL DIC
- if Y=-1
- GOTO EX^PRCFARR3
- SET PRCFPO=+Y
- +2 SET DIC="^PRC(442,"_PRCFPO_",11,"
- SET DA(1)=PRCFPO
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),""^"",19)'="""""
- DO ^DIC
- KILL DIC
- if Y=-1
- GOTO EX^PRCFARR3
- SET PRCFPR=+Y
- EN ; ENTRY POINT FOR AUTOMATIC TRANSMISSION
- +1 KILL ^TMP("PRCFARR",$JOB)
- NEW D0
- +2 if '$DATA(PRCFPO)!('$DATA(PRCFPR))
- QUIT
- if '$DATA(^PRC(442,+PRCFPO,0))
- QUIT
- +3 SET PRCF0=^PRC(442,PRCFPO,0)
- SET PRCF1=$GET(^(1))
- SET PRCF12=$GET(^(12))
- SET PRCF17=$GET(^(17))
- SET PRCF18=$GET(^(18))
- SET PRCF11=^PRC(442,PRCFPO,11,PRCFPR,0)
- SET PRCFPRD=+PRCF11
- +4 SET PRCF10=$GET(^PRC(442,PRCFPO,10,1,0))
- SET PRCFTC=$SELECT(PRCF10]"":$PIECE($PIECE(PRCF10,U),"."),1:"")
- +5 if PRCFTC'?2U
- SET PRCFTC=$SELECT($PIECE(PRCF0,U,2)=2:"SO",1:"MO")
- +6 SET PRCFOBNO=$TRANSLATE($PIECE(PRCF0,U),"-")
- SET PRCFOBNO=PRCFOBNO_$EXTRACT(" ",1,11-$LENGTH(PRCFOBNO))
- +7 NEW FED,STA,FCP,DFY,BBFY,P2237,REQ,NET
- SET STA=+PRCF0
- SET FCP=+$PIECE(PRCF0,U,3)
- +8 SET P2237=$PIECE(PRCF0,U,12)
- SET DFY=$SELECT(P2237?1.N:$PIECE($PIECE($GET(^PRCS(410,P2237,0)),U),"-",2),1:"")
- SET REQ=""
- +9 SET BBFY=$PIECE($GET(^PRC(442,PRCFPO,23)),U,2)
- if BBFY
- SET BBFY=1700+$EXTRACT(BBFY,1,3)
- +10 IF STA
- IF DFY
- IF FCP
- IF 'BBFY
- SET BBFY=$$BBFY^PRCSUT(STA,DFY,FCP)
- +11 IF STA
- IF FCP
- IF DFY
- IF BBFY
- SET REQ=$$ACC^PRC0C(STA,FCP_U_DFY_U_BBFY)
- +12 SET NET=1
- IF $PIECE(REQ,U,12)="G"
- SET NET=0
- +13 NEW PRCACT,PRCFBNO
- SET PRCACT="E"
- SET PRCFBNO=""
- SET LCKFLG=0
- +14 IF +$PIECE(PRCF11,U,3)<0!(+$PIECE(PRCF11,U,5)<0)
- Begin DoDot:1
- +15 SET PRCACT="M"
- DO GETBN(+PRCF0,.PRCFBNO)
- if LCKFLG
- QUIT
- +16 if $PIECE(^PRC(442,PRCFPO,11,PRCFPR,0),U,20)=""
- SET $PIECE(^(0),U,20)=PRCFBNO
- +17 SET PRCFBNO=+PRCF0_$EXTRACT(1000+PRCFBNO,2,4)
- End DoDot:1
- if LCKFLG
- QUIT
- +18 IF $PIECE(PRCF0,"^",8)
- IF $PIECE(PRCF0,"^",8)<$PIECE(PRCF0,"^",6)
- SET $PIECE(PRCF0,"^",6,9)=$PIECE(PRCF0,"^",8,9)_"^"_$PIECE(PRCF0,"^",6,7)
- +19 IF '$DATA(PRCFJDN)
- SET X=$PIECE(PRCF1,"^",15)
- DO JDN^PRCUTL
- SET PRCFJDN=Y
- +20 ;N PNO S PNO="00"_PRCFPR,PNO=$E(PNO,$L(PNO)-1,$L(PNO)) ; Partial #
- +21 NEW PNO
- SET PNO=""
- SET X=$SELECT(PRCACT="M"&($PIECE($GET(^PRC(442,PRCFPO,11,PRCFPR,1)),U,16)?1.N):$PIECE(^(1),U,16),1:PRCFPR)
- +22 ; IFCAP ==> FMS Partial #
- DO ALPHA^PRCFPAR(X,.PNO)
- +23 IF PNO<0
- Begin DoDot:1
- +24 SET X="Partial # is out of limits - FMS will not process.*"
- +25 DO MSG^PRCFQ
- +26 QUIT
- End DoDot:1
- GOTO EX^PRCFARR3
- +27 SET FED=0
- IF $PIECE(PRCF1,U,7)]""
- IF "13578"[$PIECE(PRCF1,U,7)
- SET FED=2
- +28 NEW SPLIT
- SET SPLIT=$SELECT(FED:"A",1:" ")
- +29 if FED
- SET AGYCD=$PIECE(^PRCD(420.8,$PIECE(PRCF1,U,7),0),U,5)
- +30 NEW SEC1
- SET SEC1=$EXTRACT($$SEC1^PRC0C(PRC("SITE"))_" ",1,4)
- S1 ;#1 SPLIT,STATION,PAT,PARTIAL NO.,PARTIAL DATE,JULIAN DATE,LINE/ITEM COUNT,CASCA PROJECT #,TRANS TYPE,SEC1,BATCH#,REF TRANS CODE & #,DOC ACTION
- +1 SET TMP=SPLIT_"^1^"_+PRCF0_"^"_$PIECE($PIECE(PRCF0,"^",1),"-",2)_"^"_PNO_"^"_$EXTRACT(PRCF11,4,7)_$EXTRACT(PRCF11,2,3)_"^"_$PIECE(PRCF0,"^",14)_"^"
- +2 if FED
- SET TMP=TMP_AGYCD_U_PRCFJDN_U_$PIECE(PRCF18,U,13)_U_$PIECE(PRCF18,U,14)_U
- +3 SET TMP=TMP_SEC1_U_PRCFBNO_U_PRCFTC_U_PRCFOBNO_U_PRCACT_U_"001"_U
- +4 SET ^TMP("PRCFARR",$JOB,1,0)=TMP
- S2 ;#2 VENDOR NAME, ADDRESS, PHONE
- +1 SET PRCFX=""
- SET X=$GET(^PRC(440,+PRCF1,0))
- SET $PIECE(PRCFX,"^",1,6)="2^"_$PIECE(X,"^",1,5)
- SET $PIECE(PRCFX,"^",7)=$EXTRACT($PIECE(X,"^",6),1,19)_" "_$SELECT($DATA(^DIC(5,+$PIECE(X,"^",7),0)):$PIECE(^(0),"^",2),1:"")_" "_$PIECE(X,"^",8)
- SET $PIECE(PRCFX,"^",8)=$EXTRACT($PIECE(X,"^",10),1,18)
- +2 NEW VN
- SET VN=$PIECE(PRCFX,U,2)
- SET $PIECE(PRCFX,U,2)=$EXTRACT(VN,1,30)
- +3 SET ^TMP("PRCFARR",$JOB,2,0)=PRCFX_"^"
- S3 ;#3 SHIP TO ADDRESS
- +1 SET D0=PRCFPO
- SET (X,PRCFX)=""
- +2 IF +$PIECE(PRCF0,"^",2)'=4
- Begin DoDot:1
- +3 SET PRC("SITE")=+PRCF0
- DO FTYP^PRCHFPNT
- +4 SET X=$SELECT($PIECE($GET(^PRC(442,PRCFPO,23)),U,7)]"":$PIECE(^(23),U,7),1:+PRCF0)
- +5 SET X=$SELECT($DATA(^PRC(411,X,1,+$PIECE(PRCF1,"^",3),0)):^(0),1:"")
- +6 if X]""
- SET $PIECE(X,"^")=$PIECE(X,"^")_"^"_$EXTRACT(PRCHFTYP,1,24)
- End DoDot:1
- +7 IF +$PIECE(PRCF0,"^",2)=4
- IF $PIECE(PRCF1,"^",12)]""
- SET X=$SELECT($DATA(^PRC(440.2,$PIECE(PRCF1,"^",12),0)):^(0),1:"")
- if X]""
- SET $PIECE(X,"^")=$SELECT($DATA(^DPT(+X,0)):$EXTRACT($PIECE(^(0),"^",1),1,21),1:+X)
- SET $PIECE(X,"^",4)=$PIECE(X,"^",4)_"^"
- +8 SET $PIECE(PRCFX,"^",1,6)="3^"_$EXTRACT($PIECE(X,"^",1),1,30)_"^"_$PIECE(X,"^",2,5)
- SET $PIECE(PRCFX,"^",7)=$PIECE(X,"^",6)_" "_$SELECT($DATA(^DIC(5,+$PIECE(X,"^",7),0)):$PIECE(^(0),"^",2),1:"")_" "_$PIECE(X,"^",8)
- SET ^TMP("PRCFARR",$JOB,3,0)=PRCFX_"^"
- S4 ;#4 REQ.SERVICE,GBL#,TYPE OF ORDER,PROPOSAL,CONTRACT(S)
- +1 SET Y=$SELECT($DATA(^PRCD(420.8,+$PIECE(PRCF1,"^",7),0)):$PIECE(^(0),"^"),1:"")
- SET Y=$SELECT(Y=2:"P",Y?1"B":Y,1:"D")
- +2 SET Z="^^"
- SET (X,Z1)=""
- FOR I=1:1:3
- SET X=$ORDER(^PRC(442,PRCFPO,2,"AC",X))
- if X=""
- QUIT
- if $ORDER(^(X,0))
- SET Z1=^($ORDER(^(0)))
- SET $PIECE(Z,"^",I)=Z1_X
- SET Z1=""
- +3 SET X=$SELECT($DATA(^DIC(49,+$PIECE(PRCF1,"^",2),0)):^(0),1:"")
- SET Z1=$SELECT($PIECE(X,"^",8)]"":"("_$PIECE(X,"^",8)_")",1:"")
- SET X=$EXTRACT($PIECE(X,"^"),1,(30-$LENGTH(Z1)))_Z1
- SET Z1=""
- +4 SET ^TMP("PRCFARR",$JOB,4,0)="4^"_X_"^"_$PIECE(PRCF12,"^",7)_"^"_Y_"^"_$PIECE(PRCF1,"^",8)_"^"_Z_"^"
- SET $PIECE(^(0),U,9)=""
- +5 GOTO EN^PRCFARR0
- FAMT IF 'X
- SET X=""
- QUIT
- +1 SET X=$PIECE(X,".")_$EXTRACT($PIECE(X,".",2)_"00",1,2)
- QUIT
- W1 WRITE !!,"Receiving Report is incomplete. Cannot transmit!",$CHAR(7)
- QUIT
- GETBN(PRCSTA,PRCX) ;Get Batch #
- +1 NEW PRCFDA,X,Y
- +2 IF $PIECE(^PRC(442,PRCFPO,11,PRCFPR,0),U,20)]""
- SET PRCX=$PIECE(^(0),U,20)
- QUIT
- +3 SET X=PRCSTA_"-RRT-00"
- SET DIC=422.2
- SET DIC(0)="XL"
- SET DLAYGO=422.2
- DO ^DIC
- KILL DIC,DLAYGO
- +4 IF +Y<1
- SET PRCX=-1
- QUIT
- +5 SET PRCFDA=+Y
- +6 IF $GET(PRCFA8)=1
- DO LOCK
- KILL PRCFA8
- QUIT
- +7 DO LOCK1
- QUIT
- +8 ;
- LOCK ;Process Receiving Report Option.
- +1 LOCK +^PRCF(422.2,PRCFDA):3
- +2 IF '$TEST
- Begin DoDot:1
- +3 SET LCKFLG=1
- +4 DO EN^DDIOL("Record in use please try later.")
- QUIT
- End DoDot:1
- if LCKFLG
- QUIT
- +5 ;
- +6 IF +$PIECE(Y,U,3)
- SET $PIECE(^PRCF(422.2,PRCFDA,0),U,2)=500
- +7 SET PRCX=$PIECE($GET(^PRCF(422.2,PRCFDA,0)),U,2)+1
- +8 if PRCX>999
- SET PRCX=1
- SET $PIECE(^PRCF(422.2,PRCFDA,0),U,2)=PRCX
- +9 LOCK -^PRCF(422.2,PRCFDA)
- +10 QUIT
- +11 ;
- LOCK1 ;Get LOCK for tasked process. If unable to obtain a LOCK
- +1 ;after 5 minutes (300 seconds) exit and give the user an email.
- +2 LOCK +^PRCF(422.2,PRCFDA):300
- +3 IF '$TEST
- DO LCKMSG
- SET LCKFLG=1
- QUIT
- +4 ;
- +5 IF +$PIECE(Y,U,3)
- SET $PIECE(^PRCF(422.2,PRCFDA,0),U,2)=500
- +6 SET PRCX=$PIECE($GET(^PRCF(422.2,PRCFDA,0)),U,2)+1
- +7 if PRCX>999
- SET PRCX=1
- SET $PIECE(^PRCF(422.2,PRCFDA,0),U,2)=PRCX
- +8 LOCK -^PRCF(422.2,PRCFDA)
- +9 QUIT
- +10 ;
- LCKMSG ;Send user a message
- +1 NEW XMDUZ,MSG,MSG1
- +2 SET MSG="Error: Receiving Report NOT queued, "
- +3 SET MSG=MSG_"unable to obtain the batch transaction "
- +4 SET MSG1=" number. Please try again."
- +5 KILL ^TMP("PRCFARR",$JOB)
- +6 SET ^TMP("PRCFARR",$JOB,1,0)=MSG
- +7 SET ^TMP("PRCFARR",$JOB,2,0)=MSG1
- +8 SET XMDUZ=$SELECT($DATA(DUZ)#2:DUZ,1:.5)
- +9 SET XMY(XMDUZ)=""
- +10 SET XMSUB="RECEIVING REPORT "_$PIECE(^PRC(442,PRCFA("PODA"),0),"^",1)
- +11 SET XMSUB=XMSUB_" PARTIAL #: "_PRCFA("PARTIAL")
- +12 SET XMTEXT="^TMP(""PRCFARR"","_$JOB_","
- +13 SET XMY(XMDUZ)=""
- +14 DO ^XMD
- +15 KILL ^TMP("PRCFARR",$JOB)
- +16 QUIT