- 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 Feb 18, 2025@23:42:17 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