PRCUTL1.m

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 ---PRCUTL1   1849     printed  Apr 09, 2024@21:03:53                                                                                                                                                                                                     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