PRCFACR ;WISC/CTB/CLH-RELEASE CODE SHEETS TO AUSTIN ;4/30/93 3:04 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S PRCFASYS="CLM"
SE W !,"This option will release code sheets to the VADATS system for transmission",!,"to the Austin DPC. You will have the option of releasing individual batches",!,"or all batches within a certain Transmission Number."
S PRCF("X")="AS" D ^PRCFSITE G:'% OUT
D NOW^%DTC S PRCFKEY=%_"-"_DUZ
A W !!,"Do you wish to release by Batch or Transmission number? (B/T) T//" R X:$S($D(DTIME):DTIME,1:60)
I '$T!(X["^") G OUT
I X=""!("Tt"[$E(X)) G T
I "Bb"[$E(X) G B
W !!,"If you respond with a 'B', you will be required to enter the full Batch Number",!,"of each Batch that you wish to release to Austin. A 'T', will cause",!,"ALL batches within the Transmission to be released automatically.",!! G A
QUE I '$D(^PRCF(421.2,"AD",PRCFKEY)) W !!,"NO BATCHES SELECTED OPTION ABORTED",$C(7) G OUT
S ZTSAVE("PRCFRT")="",ZTSAVE("PRCFASYS")="",ZTSAVE("PRCFKEY")="",ZTRTN="^PRCFACR1",ZTDESC="TRANSMIT "_$S(PRCFASYS["LOG":"LOG",PRCFASYS["ISM":"ISM",1:"")_" CODE SHEETS" D ^PRCFQ G OUT
B D ES G OUT:$D(FAIL)
S DIC("A")="Select Batch Number: ",PRCFRT=0
B1 S DIC=421.2,DIC(0)="XAEMQZO",DIC("S")="S XXX=^(0) I $P(XXX,U,4)="""",$P(XXX,U,3)=""B"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
D ^DIC K DIC,XXX G:Y<0&('$D(POK)) OUT G:Y<0 QUE
S PBAT=$P(Y,U,2),PBATN=+Y S $P(^PRCF(421.2,PBATN,0),"^",15)=PRCFKEY,^PRCF(421.2,"AD",PRCFKEY,PBATN)=""
S POK="",DIC("A")="Select Next Batch Number: " G B1
T D ES G OUT:$D(FAIL) K POK
S DIC("A")="Enter Transmission Number: ",PRCFRT=0
T1 S DIC=421.2,DIC(0)="XAMEQZO",DIC("S")="S XXX=^(0) I $P(XXX,U,4)="""",$E($P(XXX,U,3),1)=""T"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
D ^DIC K DIC,XXX G:Y<0&('$D(POK)) OUT G:Y<0 QUE
S PTR=$P(Y,"^",2),PTRN=+Y
S ^PRCF(421.2,"AD",PRCFKEY,PTRN)="",$P(^PRCF(421.2,PTRN,0),"^",15)=PRCFKEY
S K=0 F I=1:1 S K=$O(^PRCF(421.2,PTRN,1,K)) Q:+K=0 S PBAT=^(K,0) W !,"Processing Batch # ",PBAT D T3
S POK="",DIC("A")="Select Next Transmission Number: " G T1
T3 S:$D(^PRCF(421.2,"B",PBAT)) PBATN=$O(^PRCF(421.2,"B",PBAT,0))
I $P(^PRCF(421.2,PBATN,0),"^",4)="" S $P(^(0),"^",15)=PRCFKEY,^PRCF(421.2,"AD",PRCFKEY,PBATN)="" Q
S X="Batch "_PBAT_" has already been released/scheduled for release. No action has been taken on this batch.*" D MSG^PRCFQ
Q
OUT K %,N,I,%DT,%H,%Y,DIC,DIJ,ER,A,B,C,DQTIME,FAIL,POP,POK,PTR,PTRN,PBAT,PBATN,PFLAG,PRCFRT,X,X1,XMDUZ,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,IOX,IOY,XMZ,Y Q
ES ;
ES1 N MESSAGE S MESSAGE=""
D ESIG^PRCUESIG(DUZ,.MESSAGE)
;S ^ZZTOMF($H,"TOM9.5",$J,DT,0)="TOM NEEL TESTING - DVA"_U_DUZ_U_"YOU HIT ES1^PRCFACR AND DID ESIG^PRCUESIG"_U_"MESSAGE = "_MESSAGE_U
G:(MESSAGE=0)!(MESSAGE=-3) FAIL
G:(MESSAGE=-1)!(MESSAGE=-2) FAIL1
Q
FAIL S FAIL="" W !,$C(7)," SIGNATURE CODE FAILURE " R X:3 Q
FAIL1 S FAIL="" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACR 2937 printed Dec 13, 2024@02:02:07 Page 2
PRCFACR ;WISC/CTB/CLH-RELEASE CODE SHEETS TO AUSTIN ;4/30/93 3:04 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET PRCFASYS="CLM"
SE WRITE !,"This option will release code sheets to the VADATS system for transmission",!,"to the Austin DPC. You will have the option of releasing individual batches",!,"or all batches within a certain Transmission Number."
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
GOTO OUT
+2 DO NOW^%DTC
SET PRCFKEY=%_"-"_DUZ
A WRITE !!,"Do you wish to release by Batch or Transmission number? (B/T) T//"
READ X:$SELECT($DATA(DTIME):DTIME,1:60)
+1 IF '$TEST!(X["^")
GOTO OUT
+2 IF X=""!("Tt"[$EXTRACT(X))
GOTO T
+3 IF "Bb"[$EXTRACT(X)
GOTO B
+4 WRITE !!,"If you respond with a 'B', you will be required to enter the full Batch Number",!,"of each Batch that you wish to release to Austin. A 'T', will cause",!,"ALL batches within the Transmission to be released automatically.",!!
GOTO A
QUE IF '$DATA(^PRCF(421.2,"AD",PRCFKEY))
WRITE !!,"NO BATCHES SELECTED OPTION ABORTED",$CHAR(7)
GOTO OUT
+1 SET ZTSAVE("PRCFRT")=""
SET ZTSAVE("PRCFASYS")=""
SET ZTSAVE("PRCFKEY")=""
SET ZTRTN="^PRCFACR1"
SET ZTDESC="TRANSMIT "_$SELECT(PRCFASYS["LOG":"LOG",PRCFASYS["ISM":"ISM",1:"")_" CODE SHEETS"
DO ^PRCFQ
GOTO OUT
B DO ES
if $DATA(FAIL)
GOTO OUT
+1 SET DIC("A")="Select Batch Number: "
SET PRCFRT=0
B1 SET DIC=421.2
SET DIC(0)="XAEMQZO"
SET DIC("S")="S XXX=^(0) I $P(XXX,U,4)="""",$P(XXX,U,3)=""B"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
+1 DO ^DIC
KILL DIC,XXX
if Y<0&('$DATA(POK))
GOTO OUT
if Y<0
GOTO QUE
+2 SET PBAT=$PIECE(Y,U,2)
SET PBATN=+Y
SET $PIECE(^PRCF(421.2,PBATN,0),"^",15)=PRCFKEY
SET ^PRCF(421.2,"AD",PRCFKEY,PBATN)=""
+3 SET POK=""
SET DIC("A")="Select Next Batch Number: "
GOTO B1
T DO ES
if $DATA(FAIL)
GOTO OUT
KILL POK
+1 SET DIC("A")="Enter Transmission Number: "
SET PRCFRT=0
T1 SET DIC=421.2
SET DIC(0)="XAMEQZO"
SET DIC("S")="S XXX=^(0) I $P(XXX,U,4)="""",$E($P(XXX,U,3),1)=""T"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
+1 DO ^DIC
KILL DIC,XXX
if Y<0&('$DATA(POK))
GOTO OUT
if Y<0
GOTO QUE
+2 SET PTR=$PIECE(Y,"^",2)
SET PTRN=+Y
+3 SET ^PRCF(421.2,"AD",PRCFKEY,PTRN)=""
SET $PIECE(^PRCF(421.2,PTRN,0),"^",15)=PRCFKEY
+4 SET K=0
FOR I=1:1
SET K=$ORDER(^PRCF(421.2,PTRN,1,K))
if +K=0
QUIT
SET PBAT=^(K,0)
WRITE !,"Processing Batch # ",PBAT
DO T3
+5 SET POK=""
SET DIC("A")="Select Next Transmission Number: "
GOTO T1
T3 if $DATA(^PRCF(421.2,"B",PBAT))
SET PBATN=$ORDER(^PRCF(421.2,"B",PBAT,0))
+1 IF $PIECE(^PRCF(421.2,PBATN,0),"^",4)=""
SET $PIECE(^(0),"^",15)=PRCFKEY
SET ^PRCF(421.2,"AD",PRCFKEY,PBATN)=""
QUIT
+2 SET X="Batch "_PBAT_" has already been released/scheduled for release. No action has been taken on this batch.*"
DO MSG^PRCFQ
+3 QUIT
OUT KILL %,N,I,%DT,%H,%Y,DIC,DIJ,ER,A,B,C,DQTIME,FAIL,POP,POK,PTR,PTRN,PBAT,PBATN,PFLAG,PRCFRT,X,X1,XMDUZ,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,IOX,IOY,XMZ,Y
QUIT
ES ;
ES1 NEW MESSAGE
SET MESSAGE=""
+1 DO ESIG^PRCUESIG(DUZ,.MESSAGE)
+2 ;S ^ZZTOMF($H,"TOM9.5",$J,DT,0)="TOM NEEL TESTING - DVA"_U_DUZ_U_"YOU HIT ES1^PRCFACR AND DID ESIG^PRCUESIG"_U_"MESSAGE = "_MESSAGE_U
+3 if (MESSAGE=0)!(MESSAGE=-3)
GOTO FAIL
+4 if (MESSAGE=-1)!(MESSAGE=-2)
GOTO FAIL1
+5 QUIT
FAIL SET FAIL=""
WRITE !,$CHAR(7)," SIGNATURE CODE FAILURE "
READ X:3
QUIT
FAIL1 SET FAIL=""
QUIT
