- PRCFACP2 ;WISC@ALTOONA/CTB-CONTINUATION OF PRCFACP1 ;4/7/93 11:23
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- BATCH ;GET NEXT BATCH NUMBER GIVEN STATION NUMBER
- I PTYP=1 G BAT1
- S PRCFLN=9999,X=PRC("SITE")_"-"_$E(PRCFASYS,1,3)_"-"_PMO
- D COUNTER^PRCFACP Q:Y<0 S X=PRC("SITE")_"-"_$E(PRCFASYS,1,3)_"-"_$E(PMO,2,3)_"-"_$E(PMO,4,5)_$E("000"_Y,$L(Y),10) K Y G BAT2
- BAT1 S X=PRC("SITE")_"-"_$E(PRCFASYS,1,3)_"-"_PMO_"P" D COUNTER^PRCFACP Q:Y<0 I $E(Y,$L(Y)-1,$L(Y))="00" G BAT1
- S X="0"_Y_$C(67+(Y\100)),X=$E(PMO,4,5)_$E(X,$L(X)-2,$L(X)),X=PRC("SITE")_"-"_$E(PRCFASYS,1,3)_"-"_$E(PMO,2,3)_"-"_X
- BAT2 S:'$D(PTR) PTR="NOT ASSIGNED" S (DIC,DLAYGO)=421.2,DIC(0)="MOLZ",PBAT=X D ^DIC K DLAYGO Q:Y<0 S (DA,PBATN)=+Y D NOW^%DTC S DIE=DIC,DR=".5////B;1////"_PTR_";.7////"_%_";.8////"_DUZ D ^DIE
- Q:'$D(PTRN) Q:PTRN=""
- I '$D(^PRCF(421.2,PTRN,1,0)) S ^(0)="^421.21A^^"
- S X=$P(^PRCF(421.2,PTRN,1,0),"^",3)+1,^(0)=$P(^(0),"^",1,2)_"^"_X_"^"_X,^(X,0)=PBAT
- Q
- CREATE ;CREATE NEW HEADER CARD TYPE 999 FOR BATCH NUMBER (PBAT)
- N PDATE1 S X="BCH-"_PBAT,DIC="^PRCF(423,",DLAYGO=423,DIC(0)="LMX" D FILE^DICN K DIC,DLAYGO Q:Y<0 S A=+Y
- I "CLI"[$G(PRCFASYS),$D(PRCFA("CSDA")),$D(^PRCF(423,PRCFA("CSDA"),"CODE",0)) S PRCF(PMOTYP)=$P(^PRCF(423,PRCFA("CSDA"),"CODE",0),U,4)
- S X="00"_PRCF(PMOTYP),X=$E(X,$L(X)-1,$L(X))
- I '$D(T) D NOW^PRCFQ S T=X
- S:'$D(PTECH) PTECH=+PRC("PER")
- S $P(^PRCF(423,A,0),"^",2,9)=PRC("SITE")_"^^999."_X_"^^^^"_PTECH,^("TRANS")="N"_"^^"_T_"^"_PTYP_"^"_PBAT_"^1^^"_PTR,^PRCF(423,"AD",PBAT,A)=""
- I '$D(PDATE) D NOW^PRCFQ S PDATE=X
- S PDATE1=$E(PDATE,4,7)_$E(PDATE,2,3)
- S ^PRCF(423,A,"CODE",0)="^423.06A^1^1",^PRCF(423,A,"CODE",1,0)=$P(^PRCF(423.9,PTYP,0),"^",5)_"."_PRC("SITE")_".999."_X_"."_PDATE1_"."_$P(PBAT,"-",4)_".$" K X
- S $P(^PRCF(423,A,"TRANS"),"^",10)=PRCFKEY,^PRCF(423,"AJ",PRCFKEY,A)=""
- Q
- PRINT ;PRINT TRANSMIT CODE DATA IN "X" CHARATER FIELD
- ;D0=internal #
- ;TAB=colum to start printing
- Q:'$D(D0)!('$D(TAB))
- N PRCF0,I,NODE,LTH,ST,END1
- S PRCF0=$G(^PRCF(423,D0,"CODE",0)) Q:PRCF0="" S END=(IOM-TAB)
- F I=1:1:$P(PRCF0,"^",3) S NODE=$G(^PRCF(423,D0,"CODE",I,0)),ST=1,END1=END D:$D(NODE) ;
- .S LTH=($L(NODE)+END) F Q:END1>LTH W ?TAB,$E(NODE,ST,END1),! S ST=ST+END,END1=END1+END
- .QUIT
- Q
- ASSIGN ;ASSIGN CODE SHEETS TO BATCHES BY MONTH, BATCH TYPE AND PRIORITY
- ;MOVED FROM PRCFACP1 DUE TO SIZE LIMITATIONS
- N CYCLE S (CYCLE,PMOTYP)=0 F PRCFJ=1:1 S PMOTYP=$O(^TMP("PRCF-BATCH",$J,PMOTYP)) Q:'PMOTYP S PMO=$P(PMOTYP,"-"),PTYP=$P(PMOTYP,"-",2),CYCLE=0 D C
- K PRCFJ S PMOTYP=0 Q
- C K PRCF(PMOTYP) D BATCH
- S PRCF(PMOTYP)=0,PCOUNT=$S($D(^PRCF(423.9,PTYP,0)):$P(^(0),"^",3),1:"") S:+PCOUNT=0 PCOUNT=100
- S PRIO=0 F PRCFL=1:1 S PRIO=$O(^TMP("PRCF-BATCH",$J,PMOTYP,PRIO)) Q:'PRIO D D
- D:"1,2,3,4,9,10,12"[PTYP CREATE K PRCFL S PRIO=0 Q
- D N PCODE1,PCODE2 S DA=0 F PRCFK=1:1 S DA=$O(^TMP("PRCF-BATCH",$J,PMOTYP,PRIO,DA)) Q:DA="" S PCODE1=$G(^PRCF(423,DA,"CODE",1,0)),PCODE1=$E(PCODE1,9,14),^TMP($J,"PCODE",PCODE1,DA)=""
- S PCODE2=0 F S PCODE2=$O(^TMP($J,"PCODE",PCODE2)),DA=0 Q:PCODE2="" F S DA=$O(^TMP($J,"PCODE",PCODE2,DA)) Q:DA="" D E
- K PRCFK,^TMP($J,"PCODE") Q
- E N PCODE,PTRAN
- S PCODE=$G(^PRCF(423,DA,"CODE",1,0)),PTRAN=$G(^PRCF(423,DA,"TRANS"))
- S PRCF("CSDA")=DA I $D(PRCF(PMOTYP))[0 S PRCF(PMOTYP)=0 D BATCH
- I CYCLE=1,"960.00,960.01,960.02,960.26,960.30,960.81"'[$E(PCODE,9,14) D CREATE,BATCH S (CYCLE,PRCF(PMOTYP))=0
- I +PRCF(PMOTYP)>0 D
- .I (+CYCLE=0)&(("960.00,960.01,960.02,960.26,960.30,960.81"[$E(PCODE,9,14))&($P(PTRAN,"^",5)="")) D CREATE,BATCH S PRCF(PMOTYP)=0
- .QUIT
- S:"960.00,960.01,960.02,960.26,960.30,960.81"[$E(PCODE,9,14) CYCLE=1
- I PRCF(PMOTYP)'<PCOUNT D:"1,2,3,4,9,10,12"[PTYP CREATE D BATCH S (CYCLE,PRCF(PMOTYP))=0
- S DA=PRCF("CSDA") K PRCF("CSDA") S X=$P(^PRCF(423,DA,0),"^",5),%DT="" S X=$E(X,1,2)_" "_$E(X,3,4)_" "_$E(X,5,6) D ^%DT
- S X=Y S:'$D(PDATE) PDATE=0 S:X>PDATE PDATE=X
- S PRCF("T")=^PRCF(423,DA,"TRANS"),$P(PRCF("T"),"^",5)=PBAT,$P(PRCF("T"),"^",8)=PTR,^("TRANS")=PRCF("T"),^PRCF(423,"AD",PBAT,DA)=""
- S PRCF(PMOTYP)=PRCF(PMOTYP)+1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACP2 4109 printed Jan 18, 2025@03:03:17 Page 2
- PRCFACP2 ;WISC@ALTOONA/CTB-CONTINUATION OF PRCFACP1 ;4/7/93 11:23
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- BATCH ;GET NEXT BATCH NUMBER GIVEN STATION NUMBER
- +1 IF PTYP=1
- GOTO BAT1
- +2 SET PRCFLN=9999
- SET X=PRC("SITE")_"-"_$EXTRACT(PRCFASYS,1,3)_"-"_PMO
- +3 DO COUNTER^PRCFACP
- if Y<0
- QUIT
- SET X=PRC("SITE")_"-"_$EXTRACT(PRCFASYS,1,3)_"-"_$EXTRACT(PMO,2,3)_"-"_$EXTRACT(PMO,4,5)_$EXTRACT("000"_Y,$LENGTH(Y),10)
- KILL Y
- GOTO BAT2
- BAT1 SET X=PRC("SITE")_"-"_$EXTRACT(PRCFASYS,1,3)_"-"_PMO_"P"
- DO COUNTER^PRCFACP
- if Y<0
- QUIT
- IF $EXTRACT(Y,$LENGTH(Y)-1,$LENGTH(Y))="00"
- GOTO BAT1
- +1 SET X="0"_Y_$CHAR(67+(Y\100))
- SET X=$EXTRACT(PMO,4,5)_$EXTRACT(X,$LENGTH(X)-2,$LENGTH(X))
- SET X=PRC("SITE")_"-"_$EXTRACT(PRCFASYS,1,3)_"-"_$EXTRACT(PMO,2,3)_"-"_X
- BAT2 if '$DATA(PTR)
- SET PTR="NOT ASSIGNED"
- SET (DIC,DLAYGO)=421.2
- SET DIC(0)="MOLZ"
- SET PBAT=X
- DO ^DIC
- KILL DLAYGO
- if Y<0
- QUIT
- SET (DA,PBATN)=+Y
- DO NOW^%DTC
- SET DIE=DIC
- SET DR=".5////B;1////"_PTR_";.7////"_%_";.8////"_DUZ
- DO ^DIE
- +1 if '$DATA(PTRN)
- QUIT
- if PTRN=""
- QUIT
- +2 IF '$DATA(^PRCF(421.2,PTRN,1,0))
- SET ^(0)="^421.21A^^"
- +3 SET X=$PIECE(^PRCF(421.2,PTRN,1,0),"^",3)+1
- SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_X_"^"_X
- SET ^(X,0)=PBAT
- +4 QUIT
- CREATE ;CREATE NEW HEADER CARD TYPE 999 FOR BATCH NUMBER (PBAT)
- +1 NEW PDATE1
- SET X="BCH-"_PBAT
- SET DIC="^PRCF(423,"
- SET DLAYGO=423
- SET DIC(0)="LMX"
- DO FILE^DICN
- KILL DIC,DLAYGO
- if Y<0
- QUIT
- SET A=+Y
- +2 IF "CLI"[$GET(PRCFASYS)
- IF $DATA(PRCFA("CSDA"))
- IF $DATA(^PRCF(423,PRCFA("CSDA"),"CODE",0))
- SET PRCF(PMOTYP)=$PIECE(^PRCF(423,PRCFA("CSDA"),"CODE",0),U,4)
- +3 SET X="00"_PRCF(PMOTYP)
- SET X=$EXTRACT(X,$LENGTH(X)-1,$LENGTH(X))
- +4 IF '$DATA(T)
- DO NOW^PRCFQ
- SET T=X
- +5 if '$DATA(PTECH)
- SET PTECH=+PRC("PER")
- +6 SET $PIECE(^PRCF(423,A,0),"^",2,9)=PRC("SITE")_"^^999."_X_"^^^^"_PTECH
- SET ^("TRANS")="N"_"^^"_T_"^"_PTYP_"^"_PBAT_"^1^^"_PTR
- SET ^PRCF(423,"AD",PBAT,A)=""
- +7 IF '$DATA(PDATE)
- DO NOW^PRCFQ
- SET PDATE=X
- +8 SET PDATE1=$EXTRACT(PDATE,4,7)_$EXTRACT(PDATE,2,3)
- +9 SET ^PRCF(423,A,"CODE",0)="^423.06A^1^1"
- SET ^PRCF(423,A,"CODE",1,0)=$PIECE(^PRCF(423.9,PTYP,0),"^",5)_"."_PRC("SITE")_".999."_X_"."_PDATE1_"."_$PIECE(PBAT,"-",4)_".$"
- KILL X
- +10 SET $PIECE(^PRCF(423,A,"TRANS"),"^",10)=PRCFKEY
- SET ^PRCF(423,"AJ",PRCFKEY,A)=""
- +11 QUIT
- PRINT ;PRINT TRANSMIT CODE DATA IN "X" CHARATER FIELD
- +1 ;D0=internal #
- +2 ;TAB=colum to start printing
- +3 if '$DATA(D0)!('$DATA(TAB))
- QUIT
- +4 NEW PRCF0,I,NODE,LTH,ST,END1
- +5 SET PRCF0=$GET(^PRCF(423,D0,"CODE",0))
- if PRCF0=""
- QUIT
- SET END=(IOM-TAB)
- +6 ;
- FOR I=1:1:$PIECE(PRCF0,"^",3)
- SET NODE=$GET(^PRCF(423,D0,"CODE",I,0))
- SET ST=1
- SET END1=END
- if $DATA(NODE)
- Begin DoDot:1
- +7 SET LTH=($LENGTH(NODE)+END)
- FOR
- if END1>LTH
- QUIT
- WRITE ?TAB,$EXTRACT(NODE,ST,END1),!
- SET ST=ST+END
- SET END1=END1+END
- +8 QUIT
- End DoDot:1
- +9 QUIT
- ASSIGN ;ASSIGN CODE SHEETS TO BATCHES BY MONTH, BATCH TYPE AND PRIORITY
- +1 ;MOVED FROM PRCFACP1 DUE TO SIZE LIMITATIONS
- +2 NEW CYCLE
- SET (CYCLE,PMOTYP)=0
- FOR PRCFJ=1:1
- SET PMOTYP=$ORDER(^TMP("PRCF-BATCH",$JOB,PMOTYP))
- if 'PMOTYP
- QUIT
- SET PMO=$PIECE(PMOTYP,"-")
- SET PTYP=$PIECE(PMOTYP,"-",2)
- SET CYCLE=0
- DO C
- +3 KILL PRCFJ
- SET PMOTYP=0
- QUIT
- C KILL PRCF(PMOTYP)
- DO BATCH
- +1 SET PRCF(PMOTYP)=0
- SET PCOUNT=$SELECT($DATA(^PRCF(423.9,PTYP,0)):$PIECE(^(0),"^",3),1:"")
- if +PCOUNT=0
- SET PCOUNT=100
- +2 SET PRIO=0
- FOR PRCFL=1:1
- SET PRIO=$ORDER(^TMP("PRCF-BATCH",$JOB,PMOTYP,PRIO))
- if 'PRIO
- QUIT
- DO D
- +3 if "1,2,3,4,9,10,12"[PTYP
- DO CREATE
- KILL PRCFL
- SET PRIO=0
- QUIT
- D NEW PCODE1,PCODE2
- SET DA=0
- FOR PRCFK=1:1
- SET DA=$ORDER(^TMP("PRCF-BATCH",$JOB,PMOTYP,PRIO,DA))
- if DA=""
- QUIT
- SET PCODE1=$GET(^PRCF(423,DA,"CODE",1,0))
- SET PCODE1=$EXTRACT(PCODE1,9,14)
- SET ^TMP($JOB,"PCODE",PCODE1,DA)=""
- +1 SET PCODE2=0
- FOR
- SET PCODE2=$ORDER(^TMP($JOB,"PCODE",PCODE2))
- SET DA=0
- if PCODE2=""
- QUIT
- FOR
- SET DA=$ORDER(^TMP($JOB,"PCODE",PCODE2,DA))
- if DA=""
- QUIT
- DO E
- +2 KILL PRCFK,^TMP($JOB,"PCODE")
- QUIT
- E NEW PCODE,PTRAN
- +1 SET PCODE=$GET(^PRCF(423,DA,"CODE",1,0))
- SET PTRAN=$GET(^PRCF(423,DA,"TRANS"))
- +2 SET PRCF("CSDA")=DA
- IF $DATA(PRCF(PMOTYP))[0
- SET PRCF(PMOTYP)=0
- DO BATCH
- +3 IF CYCLE=1
- IF "960.00,960.01,960.02,960.26,960.30,960.81"'[$EXTRACT(PCODE,9,14)
- DO CREATE
- DO BATCH
- SET (CYCLE,PRCF(PMOTYP))=0
- +4 IF +PRCF(PMOTYP)>0
- Begin DoDot:1
- +5 IF (+CYCLE=0)&(("960.00,960.01,960.02,960.26,960.30,960.81"[$EXTRACT(PCODE,9,14))&($PIECE(PTRAN,"^",5)=""))
- DO CREATE
- DO BATCH
- SET PRCF(PMOTYP)=0
- +6 QUIT
- End DoDot:1
- +7 if "960.00,960.01,960.02,960.26,960.30,960.81"[$EXTRACT(PCODE,9,14)
- SET CYCLE=1
- +8 IF PRCF(PMOTYP)'<PCOUNT
- if "1,2,3,4,9,10,12"[PTYP
- DO CREATE
- DO BATCH
- SET (CYCLE,PRCF(PMOTYP))=0
- +9 SET DA=PRCF("CSDA")
- KILL PRCF("CSDA")
- SET X=$PIECE(^PRCF(423,DA,0),"^",5)
- SET %DT=""
- SET X=$EXTRACT(X,1,2)_" "_$EXTRACT(X,3,4)_" "_$EXTRACT(X,5,6)
- DO ^%DT
- +10 SET X=Y
- if '$DATA(PDATE)
- SET PDATE=0
- if X>PDATE
- SET PDATE=X
- +11 SET PRCF("T")=^PRCF(423,DA,"TRANS")
- SET $PIECE(PRCF("T"),"^",5)=PBAT
- SET $PIECE(PRCF("T"),"^",8)=PTR
- SET ^("TRANS")=PRCF("T")
- SET ^PRCF(423,"AD",PBAT,DA)=""
- +12 SET PRCF(PMOTYP)=PRCF(PMOTYP)+1
- QUIT