PRCPSMGO ;WISC/RFJ/DL-create,batch,transmit code sheet ; 1/30/98
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
CODESHT(V1,V2,V3) ; create,batch,transmit v1=station number,
; v2=trancode (ADJ,etc), v3=reference number for control string
; ^tmp($j,"string",#) stores code sheets where # range is 1 and up
; if $d(ztqueued) return prcpcs(n)=code sheet number, prcpcs(b)=batch number
I '$O(^TMP($J,"STRING",0)) Q
I 'V1!(V2="") Q
N %,%I,DISYS,PRC,PRCF,PRCFASYS,PRCFA,PRCPTASK,STRING,X
S:$D(ZTQUEUED) PRCPTASK=1 D CONTROL^PRCPSMS0(V1,V2,V3) Q:STRING=""
S %=0 F X=0:1 S %=$O(^TMP($J,"STRING",%)) Q:'% S:'$O(^TMP($J,"STRING",%)) ^(%)=^TMP($J,"STRING",%)_"$"
I V2="REP"!(V2="ISS")!(V2="RET")!(V2="BAL") D LINECNT^PRCPSMS0(X,V3) S STRING=STRING_STRING("LC")
S PRC("SITE")=V1,PRC("PER")=DUZ D NOW^%DTC
S PRC("FY")=$E(X,2,3) S:+$E(X,4,5)>9 PRC("FY")=$E(100+PRC("FY")+1,2,3)
S PRCFA("STRING")=STRING,PRCFASYS="ISM",PRCFA("TTF")=V2 W:'$G(PRCPTASK) !!,"creating ISMS code sheet ..." D ^PRCFACX2 Q:'$D(PRCFA("CSNAME"))
W:'$G(PRCPTASK) " CODE SHEET NUMBER: ",PRCFA("CSNAME") S:$G(PRCPTASK) PRCPCS("N")=PRCFA("CSNAME")
W:'$G(PRCPTASK) !?5,"batching code sheet ..." D ^PRCFACB Q:'$D(PRCF("BTCH")) W:'$G(PRCPTASK) " BATCH NUMBER: ",PRCF("BTCH") S:$G(PRCPTASK) PRCPCS("B")=PRCF("BTCH")
W:'$G(PRCPTASK) !?5,"transmit code sheet ... QUEUED" D ^PRCFACBT
K ^TMP($J,"STRING")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSMGO 1461 printed Dec 13, 2024@02:15:55 Page 2
PRCPSMGO ;WISC/RFJ/DL-create,batch,transmit code sheet ; 1/30/98
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
CODESHT(V1,V2,V3) ; create,batch,transmit v1=station number,
+1 ; v2=trancode (ADJ,etc), v3=reference number for control string
+2 ; ^tmp($j,"string",#) stores code sheets where # range is 1 and up
+3 ; if $d(ztqueued) return prcpcs(n)=code sheet number, prcpcs(b)=batch number
+4 IF '$ORDER(^TMP($JOB,"STRING",0))
QUIT
+5 IF 'V1!(V2="")
QUIT
+6 NEW %,%I,DISYS,PRC,PRCF,PRCFASYS,PRCFA,PRCPTASK,STRING,X
+7 if $DATA(ZTQUEUED)
SET PRCPTASK=1
DO CONTROL^PRCPSMS0(V1,V2,V3)
if STRING=""
QUIT
+8 SET %=0
FOR X=0:1
SET %=$ORDER(^TMP($JOB,"STRING",%))
if '%
QUIT
if '$ORDER(^TMP($JOB,"STRING",%))
SET ^(%)=^TMP($JOB,"STRING",%)_"$"
+9 IF V2="REP"!(V2="ISS")!(V2="RET")!(V2="BAL")
DO LINECNT^PRCPSMS0(X,V3)
SET STRING=STRING_STRING("LC")
+10 SET PRC("SITE")=V1
SET PRC("PER")=DUZ
DO NOW^%DTC
+11 SET PRC("FY")=$EXTRACT(X,2,3)
if +$EXTRACT(X,4,5)>9
SET PRC("FY")=$EXTRACT(100+PRC("FY")+1,2,3)
+12 SET PRCFA("STRING")=STRING
SET PRCFASYS="ISM"
SET PRCFA("TTF")=V2
if '$GET(PRCPTASK)
WRITE !!,"creating ISMS code sheet ..."
DO ^PRCFACX2
if '$DATA(PRCFA("CSNAME"))
QUIT
+13 if '$GET(PRCPTASK)
WRITE " CODE SHEET NUMBER: ",PRCFA("CSNAME")
if $GET(PRCPTASK)
SET PRCPCS("N")=PRCFA("CSNAME")
+14 if '$GET(PRCPTASK)
WRITE !?5,"batching code sheet ..."
DO ^PRCFACB
if '$DATA(PRCF("BTCH"))
QUIT
if '$GET(PRCPTASK)
WRITE " BATCH NUMBER: ",PRCF("BTCH")
if $GET(PRCPTASK)
SET PRCPCS("B")=PRCF("BTCH")
+15 if '$GET(PRCPTASK)
WRITE !?5,"transmit code sheet ... QUEUED"
DO ^PRCFACBT
+16 KILL ^TMP($JOB,"STRING")
+17 QUIT
