- 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 ---[H[J[2J[HPRCFACX2 2312 printed Apr 23, 2025@18:16:48 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
