PRCFACX2.m

PRCFACX2 ;WISC/CTB/CLH-PASS STRING TO CODE SHEET ;6/4/93  13:21

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;BUILD AND TRANSMIT CODE SHEET AS KEY PUNCH STYLE

 ;VARIABLES REQUIRED

 ;PRCFASYS - SYSTEM ID

 ;PRCFA("TTF") - TRANSACTION TYPE - .01 FIELD FROM FILE 420.4

 ;PRC("SITE")

 ;PRC("PER")-STANDARD PERSON VARIABLE - ZERO NODE OF PERSON FILE

 ;PRCFA("STRING")-CODE SHEET STRING TO BE TRANSMITTED

 ;PRCFA("STRING",#)-ARRAY OF ADDITIONAL CODE SHEET LINES TO BE TRANSMITTED (OPTIONAL)

 ;^TMP($J,"STRING",$)-ARRAY OF ADDITIONAL CODE SHEET LINES TO BE TRANSAMITTED (OPTIONAL)

 ;OPTIONAL VARIABLES

 ;PRCF("TDATE") - TRANSMISSION DATE (OPTIONAL - IF UNDEFINED, USES CURRENT DATE

 ;PRCFA("REF")- LOG COMMON NUMBER

 ;PRCFA("PRIO") - BATCH PRIORITY - IF UNDEFINED SYSTEM DEFAULTS TO 3

 N %,I,X,B,%H,%I,%DT,D,D0,DA,DI,DIC,DIE,DQ,DR,N,P

 I $S('$D(PRCFASYS):1,PRCFASYS="":1,1:0) S PRCFASYS=""

 I $S('$D(PRCFA("TTF")):1,PRCFA("TTF")="":1,'$D(PRC("SITE")):1,PRC("SITE")="":1,'$D(PRC("PER")):1,PRC("PER")="":1,'$D(PRCFA("STRING")):1,PRCFA("STRING")="":1,1:0) S %=0 Q

 D TT^PRCFAC K PRCFA("TTF") Q:'%  S PRCFA("EDIT")="",PRCHAUTO="",PRCFA("KP")="" D NEWCS^PRCFAC K PRCHAUTO,PRCFA("KP") I '$D(PRCFA("CSNAME")) S %=0 Q

 S DA=PRCFA("CSDA")

 S MESSAGE=""

 D ENCODE^PRCFES1(DA,DUZ,.MESSAGE)

 K MESSAGE

 K BTYPE I $D(PRCFA("TTDA")),PRCFA("TTDA")]"",$D(^PRCD(420.4,PRCFA("TTDA"),0)),+$P(^(0),"^",4)>0 S BTYPE=$P(^(0),"^",4) I '$D(^PRCF(423.9,BTYPE,0)) K BTYPE

 I $D(BTYPE) S BTYPE=$P(^PRCF(423.9,BTYPE,0),"^",1) I ("^FEE^FEN^"[("^"_BTYPE_"^")) S BTYPE=$$FB^PRCS58

 I $D(PRCF("TDATE")),PRCF("TDATE")]"" S X=PRCF("TDATE")

 E  S X="TODAY"

 S DR=".31////1;.5///"_X_";.6"_$S($D(BTYPE):"///"_BTYPE,$D(PRCHLOG):"///LOG",1:"///OTHER")_";.3///N;.8///"_$S($D(PRCFA("PRIO"))["0":3,"2~3~4"[PRCFA("PRIO"):PRCFA("PRIO"),1:3) K PRCFA("PRIO")

 K TT,BTYPE S DIE="^PRCF(423,",DA=PRCFA("CSDA") D ^DIE I $D(Y)'=0 D DEL^PRCFACXM S %=0 Q

 S I=1 I $D(PRCFA("STRING"))#10 S ^PRCF(423,DA,"CODE",1,0)=PRCFA("STRING"),I=I+1

 S %=0 F I=I:1 S %=$O(PRCFA("STRING",%)) Q:'%  S ^PRCF(423,DA,"CODE",I,0)=PRCFA("STRING",%)

 S %=0 F I=I:1 S %=$O(^TMP($J,"STRING",%)) Q:'%  S ^PRCF(423,DA,"CODE",I,0)=^TMP($J,"STRING",%)

 S ^PRCF(423,DA,"CODE",0)="^423.06^"_(I-1)_"^"_(I-1)

 S %=1 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFACX2   2312     printed  Apr 09, 2024@21:06:09                                                                                                                                                                                                    Page 2

PRCFACX2  ;WISC/CTB/CLH-PASS STRING TO CODE SHEET ;6/4/93  13:21

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;BUILD AND TRANSMIT CODE SHEET AS KEY PUNCH STYLE

 +3       ;VARIABLES REQUIRED

 +4       ;PRCFASYS - SYSTEM ID

 +5       ;PRCFA("TTF") - TRANSACTION TYPE - .01 FIELD FROM FILE 420.4

 +6       ;PRC("SITE")

 +7       ;PRC("PER")-STANDARD PERSON VARIABLE - ZERO NODE OF PERSON FILE

 +8       ;PRCFA("STRING")-CODE SHEET STRING TO BE TRANSMITTED

 +9       ;PRCFA("STRING",#)-ARRAY OF ADDITIONAL CODE SHEET LINES TO BE TRANSMITTED (OPTIONAL)

 +10      ;^TMP($J,"STRING",$)-ARRAY OF ADDITIONAL CODE SHEET LINES TO BE TRANSAMITTED (OPTIONAL)

 +11      ;OPTIONAL VARIABLES

 +12      ;PRCF("TDATE") - TRANSMISSION DATE (OPTIONAL - IF UNDEFINED, USES CURRENT DATE

 +13      ;PRCFA("REF")- LOG COMMON NUMBER

 +14      ;PRCFA("PRIO") - BATCH PRIORITY - IF UNDEFINED SYSTEM DEFAULTS TO 3

 +15       NEW %,I,X,B,%H,%I,%DT,D,D0,DA,DI,DIC,DIE,DQ,DR,N,P

 +16       IF $SELECT('$DATA(PRCFASYS):1,PRCFASYS="":1,1:0)

               SET PRCFASYS=""

 +17       IF $SELECT('$DATA(PRCFA("TTF")):1,PRCFA("TTF")="":1,'$DATA(PRC("SITE")):1,PRC("SITE")="":1,'$DATA(PRC("PER")):1,PRC("PER")="":1,'$DATA(PRCFA("STRING")):1,PRCFA("STRING")="":1,1:0)

               SET %=0

               QUIT 

 +18       DO TT^PRCFAC

           KILL PRCFA("TTF")

           if '%

               QUIT 

           SET PRCFA("EDIT")=""

           SET PRCHAUTO=""

           SET PRCFA("KP")=""

           DO NEWCS^PRCFAC

           KILL PRCHAUTO,PRCFA("KP")

           IF '$DATA(PRCFA("CSNAME"))

               SET %=0

               QUIT 

 +19       SET DA=PRCFA("CSDA")

 +20       SET MESSAGE=""

 +21       DO ENCODE^PRCFES1(DA,DUZ,.MESSAGE)

 +22       KILL MESSAGE

 +23       KILL BTYPE

           IF $DATA(PRCFA("TTDA"))

               IF PRCFA("TTDA")]""

                   IF $DATA(^PRCD(420.4,PRCFA("TTDA"),0))

                       IF +$PIECE(^(0),"^",4)>0

                           SET BTYPE=$PIECE(^(0),"^",4)

                           IF '$DATA(^PRCF(423.9,BTYPE,0))

                               KILL BTYPE

 +24       IF $DATA(BTYPE)

               SET BTYPE=$PIECE(^PRCF(423.9,BTYPE,0),"^",1)

               IF ("^FEE^FEN^"[("^"_BTYPE_"^"))

                   SET BTYPE=$$FB^PRCS58

 +25       IF $DATA(PRCF("TDATE"))

               IF PRCF("TDATE")]""

                   SET X=PRCF("TDATE")

 +26      IF '$TEST

               SET X="TODAY"

 +27       SET DR=".31////1;.5///"_X_";.6"_$SELECT($DATA(BTYPE):"///"_BTYPE,$DATA(PRCHLOG):"///LOG",1:"///OTHER")_";.3///N;.8///"_$SELECT($DATA(PRCFA("PRIO"))["0":3,"2~3~4"[PRCFA("PRIO"):PRCFA("PRIO"),1:3)

           KILL PRCFA("PRIO")

 +28       KILL TT,BTYPE

           SET DIE="^PRCF(423,"

           SET DA=PRCFA("CSDA")

           DO ^DIE

           IF $DATA(Y)'=0

               DO DEL^PRCFACXM

               SET %=0

               QUIT 

 +29       SET I=1

           IF $DATA(PRCFA("STRING"))#10

               SET ^PRCF(423,DA,"CODE",1,0)=PRCFA("STRING")

               SET I=I+1

 +30       SET %=0

           FOR I=I:1

               SET %=$ORDER(PRCFA("STRING",%))

               if '%

                   QUIT 

               SET ^PRCF(423,DA,"CODE",I,0)=PRCFA("STRING",%)

 +31       SET %=0

           FOR I=I:1

               SET %=$ORDER(^TMP($JOB,"STRING",%))

               if '%

                   QUIT 

               SET ^PRCF(423,DA,"CODE",I,0)=^TMP($JOB,"STRING",%)

 +32       SET ^PRCF(423,DA,"CODE",0)="^423.06^"_(I-1)_"^"_(I-1)

 +33       SET %=1

           QUIT