PRCFACR3 ;WISC@ALTOONA/CTB-KEYPUNCH A CODE SHEET ;2/19/93 10:59
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
I '$D(PRCFASYS) S PRCFASYS="FEEFENIRSCLI"
W !!,"This option will allow you to keypunch a "_$S('$D(PRCHLOG):"",1:"LOG "),"Code Sheet when there",!,"is no other way to get it into the system."
S PRCF("X")="AS" D ^PRCFSITE G:'% OUT
SE S X="Select "_$S('$D(PRCHLOG):"Transaction Type.Status Code",1:"LOG Transaction Type")_": " W !!,X R X:$S($D(DTIME):DTIME,1:120)
G:X=""!(X["^") OUT S DIC=420.4,DIC(0)="EMNZ" D ^DIC K DIC
S PRCFA("TTLEN")=$S(Y>0:$P(Y(0),"^",8),$D(PRCHLOG):80,1:"")
S PRCFA("SYS")=$S(Y>0:$P(Y(0),"^",6),$D(PRCHLOG):"LOG",1:"")
I Y<0 S XZ=X,%A="Transaction Type "_XZ_" not found in file.",%A(1)="Is it OK if I use "_XZ_" anyway",%=2,%B="If you answer 'YES', I will use "_XZ_" as the Transaction Type for this code sheet." D ^PRCFYN G:%<1 OUT G:%=2 SE S Y="^"_XZ K XZ
S PRCFA("TT")=$P(Y,"^",2),PRCFA("EDIT")="",PRCFA("KP")=""
AM4 D NEWCS^PRCFAC I '$D(DA) S X="No new code sheet created - Files inaccessible at this time.*" D MSG^PRCFQ G OUT
S PRCFA("CSDA")=DA
S DIE="^PRCF(423,",DR="4;112" D ^DIE I $D(Y)'=0!('$D(^PRCF(423,DA,"KEY"))) D DEL^PRCFACXM G V
G OUT:'$D(^PRCF(423,DA,"KEY",0)),OUT:+$P(^(0),"^",3)=0 S N=0,LNTH=80 D RE1,XM,XM^PRCFACXM
W !! S %A="Do you wish to enter another code sheet",%=1,%B="Answer YES if you wish to enter an additional code sheet" D ^PRCFYN G:%'=1 OUT G V
Q
RE1 I $D(^PRCF(423,DA,"KEY",0)),$P(^(0),"^",3)>0 K PRCFCS S N=0 F I=0:1 S N=$O(^PRCF(423,DA,"KEY",N)) Q:'N S PRCFCS(I)=^(N,0)
RENUM S N=$O(PRCFCS(N)) Q:N="" S LN=$L(PRCFCS(N))
G:LN=LNTH RENUM S X=N
SHORT I LN<LNTH S X=$O(PRCFCS(X)) Q:X'=+X S A=LNTH-LN,PRCFCS(N)=PRCFCS(N)_$E(PRCFCS(X),1,A) S:$L(PRCFCS(X))>0 PRCFCS(X)=$E(PRCFCS(X),A+1,$L(PRCFCS(X))) S LN=$L(PRCFCS(N)) G RENUM:LN=LNTH,SHORT
LONG I LN>LNTH S X=$O(PRCFCS(X)) S X=$S(X=+X:N+X/2,1:N+1),PRCFCS(X)=$E(PRCFCS(N),LNTH+1,999),PRCFCS(N)=$E(PRCFCS(N),1,LNTH),LN=$L(PRCFCS(X)),N=X G SHORT:LN<LNTH,LONG:LN>LNTH,RENUM
G RENUM
XM ;K ^PRCF(423,DA,"KEY")
S X=1,N=-1 K ^PRCF(423,DA,"CODE")
XM2 S ^PRCF(423,DA,"CODE",0)="^423.06^^" F I=1:1 S N=$O(PRCFCS(N)) Q:N="" I PRCFCS(N)]"" S ^PRCF(423,DA,"CODE",X,0)=PRCFCS(N) S X=X+1 G XM2
S $P(^PRCF(423,DA,"CODE",0),"^",3)=X,$P(^(0),"^",4)=X
Q
OUT K B,D,D0,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DR,K,Q,PRCFCS,S,X,XL1 Q
I $S('$D(PRCFASYS):0,PRCFASYS="":0,'$D(PRCFA("TTF")):0,PRCFA("TTF")="":0,'$D(PRC("SITE")):0,PRC("SITE")="":0,'$D(PRC("PER")):0,PRC("PER")="":0,1:1) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACR3 2731 printed Dec 13, 2024@02:02:11 Page 2
PRCFACR3 ;WISC@ALTOONA/CTB-KEYPUNCH A CODE SHEET ;2/19/93 10:59
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 IF '$DATA(PRCFASYS)
SET PRCFASYS="FEEFENIRSCLI"
+3 WRITE !!,"This option will allow you to keypunch a "_$SELECT('$DATA(PRCHLOG):"",1:"LOG "),"Code Sheet when there",!,"is no other way to get it into the system."
+4 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
GOTO OUT
SE SET X="Select "_$SELECT('$DATA(PRCHLOG):"Transaction Type.Status Code",1:"LOG Transaction Type")_": "
WRITE !!,X
READ X:$SELECT($DATA(DTIME):DTIME,1:120)
+1 if X=""!(X["^")
GOTO OUT
SET DIC=420.4
SET DIC(0)="EMNZ"
DO ^DIC
KILL DIC
+2 SET PRCFA("TTLEN")=$SELECT(Y>0:$PIECE(Y(0),"^",8),$DATA(PRCHLOG):80,1:"")
+3 SET PRCFA("SYS")=$SELECT(Y>0:$PIECE(Y(0),"^",6),$DATA(PRCHLOG):"LOG",1:"")
+4 IF Y<0
SET XZ=X
SET %A="Transaction Type "_XZ_" not found in file."
SET %A(1)="Is it OK if I use "_XZ_" anyway"
SET %=2
SET %B="If you answer 'YES', I will use "_XZ_" as the Transaction Type for this code sheet."
DO ^PRCFYN
if %<1
GOTO OUT
if %=2
GOTO SE
SET Y="^"_XZ
KILL XZ
+5 SET PRCFA("TT")=$PIECE(Y,"^",2)
SET PRCFA("EDIT")=""
SET PRCFA("KP")=""
AM4 DO NEWCS^PRCFAC
IF '$DATA(DA)
SET X="No new code sheet created - Files inaccessible at this time.*"
DO MSG^PRCFQ
GOTO OUT
+1 SET PRCFA("CSDA")=DA
+2 SET DIE="^PRCF(423,"
SET DR="4;112"
DO ^DIE
IF $DATA(Y)'=0!('$DATA(^PRCF(423,DA,"KEY")))
DO DEL^PRCFACXM
GOTO V
+3 if '$DATA(^PRCF(423,DA,"KEY",0))
GOTO OUT
if +$PIECE(^(0),"^",3)=0
GOTO OUT
SET N=0
SET LNTH=80
DO RE1
DO XM
DO XM^PRCFACXM
+4 WRITE !!
SET %A="Do you wish to enter another code sheet"
SET %=1
SET %B="Answer YES if you wish to enter an additional code sheet"
DO ^PRCFYN
if %'=1
GOTO OUT
GOTO V
+5 QUIT
RE1 IF $DATA(^PRCF(423,DA,"KEY",0))
IF $PIECE(^(0),"^",3)>0
KILL PRCFCS
SET N=0
FOR I=0:1
SET N=$ORDER(^PRCF(423,DA,"KEY",N))
if 'N
QUIT
SET PRCFCS(I)=^(N,0)
RENUM SET N=$ORDER(PRCFCS(N))
if N=""
QUIT
SET LN=$LENGTH(PRCFCS(N))
+1 if LN=LNTH
GOTO RENUM
SET X=N
SHORT IF LN<LNTH
SET X=$ORDER(PRCFCS(X))
if X'=+X
QUIT
SET A=LNTH-LN
SET PRCFCS(N)=PRCFCS(N)_$EXTRACT(PRCFCS(X),1,A)
if $LENGTH(PRCFCS(X))>0
SET PRCFCS(X)=$EXTRACT(PRCFCS(X),A+1,$LENGTH(PRCFCS(X)))
SET LN=$LENGTH(PRCFCS(N))
if LN=LNTH
GOTO RENUM
GOTO SHORT
LONG IF LN>LNTH
SET X=$ORDER(PRCFCS(X))
SET X=$SELECT(X=+X:N+X/2,1:N+1)
SET PRCFCS(X)=$EXTRACT(PRCFCS(N),LNTH+1,999)
SET PRCFCS(N)=$EXTRACT(PRCFCS(N),1,LNTH)
SET LN=$LENGTH(PRCFCS(X))
SET N=X
if LN<LNTH
GOTO SHORT
if LN>LNTH
GOTO LONG
GOTO RENUM
+1 GOTO RENUM
XM ;K ^PRCF(423,DA,"KEY")
+1 SET X=1
SET N=-1
KILL ^PRCF(423,DA,"CODE")
XM2 SET ^PRCF(423,DA,"CODE",0)="^423.06^^"
FOR I=1:1
SET N=$ORDER(PRCFCS(N))
if N=""
QUIT
IF PRCFCS(N)]""
SET ^PRCF(423,DA,"CODE",X,0)=PRCFCS(N)
SET X=X+1
GOTO XM2
+1 SET $PIECE(^PRCF(423,DA,"CODE",0),"^",3)=X
SET $PIECE(^(0),"^",4)=X
+2 QUIT
OUT KILL B,D,D0,DG,DIC,DIE,DIG,DIH,DIU,DIV,DIW,DLAYGO,DR,K,Q,PRCFCS,S,X,XL1
QUIT
+1 IF $SELECT('$DATA(PRCFASYS):0,PRCFASYS="":0,'$DATA(PRCFA("TTF")):0,PRCFA("TTF")="":0,'$DATA(PRC("SITE")):0,PRC("SITE")="":0,'$DATA(PRC("PER")):0,PRC("PER")="":0,1:1)
SET %=0
QUIT
+2 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
