- PRCBMT ;WISC@ALTOONA/CLH-MULTIPLE TRANSACTIONS ;9-6-90/10:27
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- S PRCF("X")="ABFS" D ^PRCFSITE I '% D OUT Q
- EN S (COUNT,PRCB("TN"))=0 I '$D(^PRCF(421.1,0)) W $C(7),!!,"YOU HAVE AN UNDEFINED FILE. CALL SITE MANAGER.",!! Q
- S LOCKFLG=0
- GETNUM ;GET TEMP TRANS NUMBER
- L +^PRCF(421.1,0):5
- E D EN^DDIOL("File in use. Please try later.") QUIT
- S TNUM=$P(^PRCF(421.1,0),"^",3)+1,PRCB("TN")="0000"_TNUM K TNUM
- L -^PRCF(421.1,0)
- S DIC="^PRCF(421.1,",DLAYGO=421.1,DIC(0)="LMN",X="T-"_$E(PRCB("TN"),$L(PRCB("TN"))-4,$L(PRCB("TN"))) D ^DIC K DIC S COUNT=COUNT+1 Q:COUNT>5 G:$P(Y,"^",3)'=1 GETNUM
- S PRCB("TN")=$P(Y,"^",2),DA=+Y,PRCB("TDA")=+Y
- W $C(7),!!,"This has been assigned TRANSACTION NUMBER: ",PRCB("TN"),".",!,"Please note and use for editing of this transaction.",!
- S PRCB("ASK")="" D DIE
- S %A="Enter another transaction",%B="",%=2 D ^PRCFYN I %=1 S (COUNT,PRCB("TN"))=0 G EN
- D OUT Q
- DIE ;I $D(PRCB("ASK")) D DEL Q
- S PRCB("NOFLG")=""
- D EDIT^PRCBMT1 I $D(PRCB("^")) K PRCB("^") D DEL Q
- D VERI I $D(PRCB("ERR",1)) K PRCB("ER") W !,$C(7),"This transaction contains no entries. No further action can be taken." G DIE
- I $D(PRCB("ERR")) K PRCB("ERR") S PRCB("ASK")="" D REVIEW^PRCBMT1 W !,$C(7),"This transaction contains at least one entry with no funding information.",!,"Either correct or delete this entry."
- I PRCB("NOFLG")=1 K PRCB("ASK") Q
- D PST^PRCBMT1 I $D(PRCB("^")) K PRCB("^") D DEL Q
- Q
- DEL G:LOCKFLG=1 OUT
- I '$D(PRCB("AUTOKILL")) K PRCB("AUTOKILL") S %A="Are you sure you want to DELETE temporary transaction number "_PRCB("TN"),%=2,%B="" D ^PRCFYN S:%<0 PRCB("^")="" I %'=1 S X=" <No Action Taken>" D MSG^PRCFQ Q
- K PRCB("AUTOKILL") S DIK="^PRCF(421.1,",DA=PRCB("TDA") D ^DIK S X=" <Temporary Transaction Number "_PRCB("TN")_" has been Deleted.>*" D MSG^PRCFQ W !
- OUT K DIC,DIE,DIK,DA,DUOUT,POP,X,TNUM,PRCB,PRCF("SIFY"),CNT,COUNT,TOREC,DR,REC,CHK,NXT,PRCBE,PRCBNUM,DATA,DLAYGO,FREC,LOCKFLG
- Q
- INPT ;INPUT TRANSFORM
- N DIX,DIC,D0,DO
- S DIC("S")="I $D(^PRC(420,+PRC(""SITE""),1,+Y))",DIC="^PRC(420,"_PRC("SITE")_",1,",DIC(0)="EMNQZ" D ^DIC S X=$P(Y,"^",2) I +Y<0 K X Q
- Q
- VERI ;VERIFY DATA
- K PRCB("ERR") I $S('$D(^PRCF(421.1,DA,1,0)):1,$P(^(0),"^",3)<1:1,1:0) S PRCB("ERR",1)="" QUIT
- S DA(1)=0 F I=1:1 S DA(1)=$O(^PRCF(421.1,DA,1,DA(1))) Q:'DA(1) D VER1 Q:$D(PRCB("ERR"))
- Q
- VER1 S PRCB("ERR",2,DA(1))="",REC=^PRCF(421.1,DA,1,DA(1),0),DATA=0 F J=2:1:6 I +$P(REC,"^",J)'=0 K PRCB("ERR",2,DA(1)) Q
- I $P($G(^PRCF(421.1,DA,1,DA(1),4)),"^",6)="" S PRCB("ERR",2,DA(1))=""
- Q
- POST S PRCF("X")="ABS",LOCKFLG=0,PRCB("NOFLG")="" D ^PRCFSITE Q:'%
- S DIC="^PRCF(421.1,",DIC("A")="Select TEMPORARY TRANSACTION NUMBER: ",DIC(0)="AEQMN" D ^DIC G:+Y<0 OUT S PRCB("TDA")=+Y,DA=+Y,PRCB("TN")=$P(Y,"^",2) K DIC
- D DIE S DIC("A")="Select Next TEMPORARY TRANSACTION NUMBER: " G POST
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBMT 2924 printed Feb 18, 2025@23:27:06 Page 2
- PRCBMT ;WISC@ALTOONA/CLH-MULTIPLE TRANSACTIONS ;9-6-90/10:27
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 SET PRCF("X")="ABFS"
- DO ^PRCFSITE
- IF '%
- DO OUT
- QUIT
- EN SET (COUNT,PRCB("TN"))=0
- IF '$DATA(^PRCF(421.1,0))
- WRITE $CHAR(7),!!,"YOU HAVE AN UNDEFINED FILE. CALL SITE MANAGER.",!!
- QUIT
- +1 SET LOCKFLG=0
- GETNUM ;GET TEMP TRANS NUMBER
- +1 LOCK +^PRCF(421.1,0):5
- +2 IF '$TEST
- DO EN^DDIOL("File in use. Please try later.")
- QUIT
- +3 SET TNUM=$PIECE(^PRCF(421.1,0),"^",3)+1
- SET PRCB("TN")="0000"_TNUM
- KILL TNUM
- +4 LOCK -^PRCF(421.1,0)
- +5 SET DIC="^PRCF(421.1,"
- SET DLAYGO=421.1
- SET DIC(0)="LMN"
- SET X="T-"_$EXTRACT(PRCB("TN"),$LENGTH(PRCB("TN"))-4,$LENGTH(PRCB("TN")))
- DO ^DIC
- KILL DIC
- SET COUNT=COUNT+1
- if COUNT>5
- QUIT
- if $PIECE(Y,"^",3)'=1
- GOTO GETNUM
- +6 SET PRCB("TN")=$PIECE(Y,"^",2)
- SET DA=+Y
- SET PRCB("TDA")=+Y
- +7 WRITE $CHAR(7),!!,"This has been assigned TRANSACTION NUMBER: ",PRCB("TN"),".",!,"Please note and use for editing of this transaction.",!
- +8 SET PRCB("ASK")=""
- DO DIE
- +9 SET %A="Enter another transaction"
- SET %B=""
- SET %=2
- DO ^PRCFYN
- IF %=1
- SET (COUNT,PRCB("TN"))=0
- GOTO EN
- +10 DO OUT
- QUIT
- DIE ;I $D(PRCB("ASK")) D DEL Q
- +1 SET PRCB("NOFLG")=""
- +2 DO EDIT^PRCBMT1
- IF $DATA(PRCB("^"))
- KILL PRCB("^")
- DO DEL
- QUIT
- +3 DO VERI
- IF $DATA(PRCB("ERR",1))
- KILL PRCB("ER")
- WRITE !,$CHAR(7),"This transaction contains no entries. No further action can be taken."
- GOTO DIE
- +4 IF $DATA(PRCB("ERR"))
- KILL PRCB("ERR")
- SET PRCB("ASK")=""
- DO REVIEW^PRCBMT1
- WRITE !,$CHAR(7),"This transaction contains at least one entry with no funding information.",!,"Either correct or delete this entry."
- +5 IF PRCB("NOFLG")=1
- KILL PRCB("ASK")
- QUIT
- +6 DO PST^PRCBMT1
- IF $DATA(PRCB("^"))
- KILL PRCB("^")
- DO DEL
- QUIT
- +7 QUIT
- DEL if LOCKFLG=1
- GOTO OUT
- +1 IF '$DATA(PRCB("AUTOKILL"))
- KILL PRCB("AUTOKILL")
- SET %A="Are you sure you want to DELETE temporary transaction number "_PRCB("TN")
- SET %=2
- SET %B=""
- DO ^PRCFYN
- if %<0
- SET PRCB("^")=""
- IF %'=1
- SET X=" <No Action Taken>"
- DO MSG^PRCFQ
- QUIT
- +2 KILL PRCB("AUTOKILL")
- SET DIK="^PRCF(421.1,"
- SET DA=PRCB("TDA")
- DO ^DIK
- SET X=" <Temporary Transaction Number "_PRCB("TN")_" has been Deleted.>*"
- DO MSG^PRCFQ
- WRITE !
- OUT KILL DIC,DIE,DIK,DA,DUOUT,POP,X,TNUM,PRCB,PRCF("SIFY"),CNT,COUNT,TOREC,DR,REC,CHK,NXT,PRCBE,PRCBNUM,DATA,DLAYGO,FREC,LOCKFLG
- +1 QUIT
- INPT ;INPUT TRANSFORM
- +1 NEW DIX,DIC,D0,DO
- +2 SET DIC("S")="I $D(^PRC(420,+PRC(""SITE""),1,+Y))"
- SET DIC="^PRC(420,"_PRC("SITE")_",1,"
- SET DIC(0)="EMNQZ"
- DO ^DIC
- SET X=$PIECE(Y,"^",2)
- IF +Y<0
- KILL X
- QUIT
- +3 QUIT
- VERI ;VERIFY DATA
- +1 KILL PRCB("ERR")
- IF $SELECT('$DATA(^PRCF(421.1,DA,1,0)):1,$PIECE(^(0),"^",3)<1:1,1:0)
- SET PRCB("ERR",1)=""
- QUIT
- +2 SET DA(1)=0
- FOR I=1:1
- SET DA(1)=$ORDER(^PRCF(421.1,DA,1,DA(1)))
- if 'DA(1)
- QUIT
- DO VER1
- if $DATA(PRCB("ERR"))
- QUIT
- +3 QUIT
- VER1 SET PRCB("ERR",2,DA(1))=""
- SET REC=^PRCF(421.1,DA,1,DA(1),0)
- SET DATA=0
- FOR J=2:1:6
- IF +$PIECE(REC,"^",J)'=0
- KILL PRCB("ERR",2,DA(1))
- QUIT
- +1 IF $PIECE($GET(^PRCF(421.1,DA,1,DA(1),4)),"^",6)=""
- SET PRCB("ERR",2,DA(1))=""
- +2 QUIT
- POST SET PRCF("X")="ABS"
- SET LOCKFLG=0
- SET PRCB("NOFLG")=""
- DO ^PRCFSITE
- if '%
- QUIT
- +1 SET DIC="^PRCF(421.1,"
- SET DIC("A")="Select TEMPORARY TRANSACTION NUMBER: "
- SET DIC(0)="AEQMN"
- DO ^DIC
- if +Y<0
- GOTO OUT
- SET PRCB("TDA")=+Y
- SET DA=+Y
- SET PRCB("TN")=$PIECE(Y,"^",2)
- KILL DIC
- +2 DO DIE
- SET DIC("A")="Select Next TEMPORARY TRANSACTION NUMBER: "
- GOTO POST