PRCUTL1 ;WISC/AKS-Utility to update file 410.1 ;5-11-92/08:04
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN1(X) ;X, THE TRANSACTION NUMBER ROOT, MUST BE IN THE FOLLOWING FORMATS:
; 1. 3N "-" 2N "-" 3.4N
; 2. 3N "-" 6AN
; 3. 3N "-FC"
; 4. 3N "-RQ"
; 5. 3N "-" 2N "-" N "-" 3.4N "-" 6N
; 6. 3N "-" 2N "-" N "-" 3.4N "-NONE"
;
;THIS ROUTINE WILL:
; 1. IF THE ROOT EXISTS THE COUNT FIELD WILL BE INCREMENTED AND
; THE NEW COUNT WILL BE CONCATINATED TO THE ROOT.
; 2. IF THE ROOT DOESN'T EXIST IT WILL BE ADDED AS A NEW RECORD
; AND COUNT WILL BE SET TO 1. THE COUNT WILL BE CONCATINATED
; TO THE ROOT.
; 3. IF THERE IS SOMETHING WRONG THE ROOT WILL BE SET TO "".
;THE CONCATINATED COUNT WILL BE 4N WITH LEADING ZEROS AS NEEDED.
;
;FOR ANY CHANGE TO COUNT (INCREMENTING IT OR SETTING IT TO 1) THE
;DATE FIELD WILL BE SET TO TODAY.
;
N REPINO,Y,COUNT,CL1,DIC
S REPINO=X
K DR S DIC="^PRCS(410.1,",DIC(0)="LZ",DLAYGO=410.1 D ^DIC K DIC,DLAYGO I Y>0 S COUNT=$S($P(Y,"^",3):1,1:$P(Y(0),"^",2)+1),DA=+Y
I Y'>0 W !!,"'TRANSACTION NUMBER' file is corrupt.",!,"Duplicate enteries found for entry "_X S X="" Q
S DIE="^PRCS(410.1,",DR="1///^S X=COUNT;2///TODAY" D ^DIE K DIE,DA,DR
S COUNT="0000"_COUNT,CL1=$L(COUNT),COUNT=$E(COUNT,CL1-3,CL1),X=REPINO_"-"_COUNT
QUIT
EN2(X) ;THIS ENTRY POINT DOES THE SAME THING AS EN1 EXCEPT WITHOUT ANY LOCAL
;OUTPUT TO THE CRT.
N REPINO,Y,COUNT,CL1,DIC
S REPINO=X
K DR S DIC="^PRCS(410.1,",DIC(0)="LZ",DLAYGO=410.1 D ^DIC K DIC,DLAYGO I Y>0 S COUNT=$S($P(Y,"^",3):1,1:$P(Y(0),"^",2)+1),DA=+Y
I Y'>0 S X="" Q
S DIE="^PRCS(410.1,",DR="1///^S X=COUNT;2////^S X=DT" D ^DIE K DIE,DA,DR
S COUNT="0000"_COUNT,CL1=$L(COUNT),COUNT=$E(COUNT,CL1-3,CL1),X=REPINO_"-"_COUNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCUTL1 1849 printed Oct 16, 2024@18:20:36 Page 2
PRCUTL1 ;WISC/AKS-Utility to update file 410.1 ;5-11-92/08:04
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1(X) ;X, THE TRANSACTION NUMBER ROOT, MUST BE IN THE FOLLOWING FORMATS:
+1 ; 1. 3N "-" 2N "-" 3.4N
+2 ; 2. 3N "-" 6AN
+3 ; 3. 3N "-FC"
+4 ; 4. 3N "-RQ"
+5 ; 5. 3N "-" 2N "-" N "-" 3.4N "-" 6N
+6 ; 6. 3N "-" 2N "-" N "-" 3.4N "-NONE"
+7 ;
+8 ;THIS ROUTINE WILL:
+9 ; 1. IF THE ROOT EXISTS THE COUNT FIELD WILL BE INCREMENTED AND
+10 ; THE NEW COUNT WILL BE CONCATINATED TO THE ROOT.
+11 ; 2. IF THE ROOT DOESN'T EXIST IT WILL BE ADDED AS A NEW RECORD
+12 ; AND COUNT WILL BE SET TO 1. THE COUNT WILL BE CONCATINATED
+13 ; TO THE ROOT.
+14 ; 3. IF THERE IS SOMETHING WRONG THE ROOT WILL BE SET TO "".
+15 ;THE CONCATINATED COUNT WILL BE 4N WITH LEADING ZEROS AS NEEDED.
+16 ;
+17 ;FOR ANY CHANGE TO COUNT (INCREMENTING IT OR SETTING IT TO 1) THE
+18 ;DATE FIELD WILL BE SET TO TODAY.
+19 ;
+20 NEW REPINO,Y,COUNT,CL1,DIC
+21 SET REPINO=X
+22 KILL DR
SET DIC="^PRCS(410.1,"
SET DIC(0)="LZ"
SET DLAYGO=410.1
DO ^DIC
KILL DIC,DLAYGO
IF Y>0
SET COUNT=$SELECT($PIECE(Y,"^",3):1,1:$PIECE(Y(0),"^",2)+1)
SET DA=+Y
+23 IF Y'>0
WRITE !!,"'TRANSACTION NUMBER' file is corrupt.",!,"Duplicate enteries found for entry "_X
SET X=""
QUIT
+24 SET DIE="^PRCS(410.1,"
SET DR="1///^S X=COUNT;2///TODAY"
DO ^DIE
KILL DIE,DA,DR
+25 SET COUNT="0000"_COUNT
SET CL1=$LENGTH(COUNT)
SET COUNT=$EXTRACT(COUNT,CL1-3,CL1)
SET X=REPINO_"-"_COUNT
+26 QUIT
EN2(X) ;THIS ENTRY POINT DOES THE SAME THING AS EN1 EXCEPT WITHOUT ANY LOCAL
+1 ;OUTPUT TO THE CRT.
+2 NEW REPINO,Y,COUNT,CL1,DIC
+3 SET REPINO=X
+4 KILL DR
SET DIC="^PRCS(410.1,"
SET DIC(0)="LZ"
SET DLAYGO=410.1
DO ^DIC
KILL DIC,DLAYGO
IF Y>0
SET COUNT=$SELECT($PIECE(Y,"^",3):1,1:$PIECE(Y(0),"^",2)+1)
SET DA=+Y
+5 IF Y'>0
SET X=""
QUIT
+6 SET DIE="^PRCS(410.1,"
SET DR="1///^S X=COUNT;2////^S X=DT"
DO ^DIE
KILL DIE,DA,DR
+7 SET COUNT="0000"_COUNT
SET CL1=$LENGTH(COUNT)
SET COUNT=$EXTRACT(COUNT,CL1-3,CL1)
SET X=REPINO_"-"_COUNT
