source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACP2.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.0 KB
RevLine 
[613]1PRCFACP2 ;WISC@ALTOONA/CTB-CONTINUATION OF PRCFACP1 ;4/7/93 11:23
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4BATCH ;GET NEXT BATCH NUMBER GIVEN STATION NUMBER
5 I PTYP=1 G BAT1
6 S PRCFLN=9999,X=PRC("SITE")_"-"_$E(PRCFASYS,1,3)_"-"_PMO
7 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
8BAT1 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
9 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
10BAT2 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
11 Q:'$D(PTRN) Q:PTRN=""
12 I '$D(^PRCF(421.2,PTRN,1,0)) S ^(0)="^421.21A^^"
13 S X=$P(^PRCF(421.2,PTRN,1,0),"^",3)+1,^(0)=$P(^(0),"^",1,2)_"^"_X_"^"_X,^(X,0)=PBAT
14 Q
15CREATE ;CREATE NEW HEADER CARD TYPE 999 FOR BATCH NUMBER (PBAT)
16 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
17 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)
18 S X="00"_PRCF(PMOTYP),X=$E(X,$L(X)-1,$L(X))
19 I '$D(T) D NOW^PRCFQ S T=X
20 S:'$D(PTECH) PTECH=+PRC("PER")
21 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)=""
22 I '$D(PDATE) D NOW^PRCFQ S PDATE=X
23 S PDATE1=$E(PDATE,4,7)_$E(PDATE,2,3)
24 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
25 S $P(^PRCF(423,A,"TRANS"),"^",10)=PRCFKEY,^PRCF(423,"AJ",PRCFKEY,A)=""
26 Q
27PRINT ;PRINT TRANSMIT CODE DATA IN "X" CHARATER FIELD
28 ;D0=internal #
29 ;TAB=colum to start printing
30 Q:'$D(D0)!('$D(TAB))
31 N PRCF0,I,NODE,LTH,ST,END1
32 S PRCF0=$G(^PRCF(423,D0,"CODE",0)) Q:PRCF0="" S END=(IOM-TAB)
33 F I=1:1:$P(PRCF0,"^",3) S NODE=$G(^PRCF(423,D0,"CODE",I,0)),ST=1,END1=END D:$D(NODE) ;
34 .S LTH=($L(NODE)+END) F Q:END1>LTH W ?TAB,$E(NODE,ST,END1),! S ST=ST+END,END1=END1+END
35 .QUIT
36 Q
37ASSIGN ;ASSIGN CODE SHEETS TO BATCHES BY MONTH, BATCH TYPE AND PRIORITY
38 ;MOVED FROM PRCFACP1 DUE TO SIZE LIMITATIONS
39 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
40 K PRCFJ S PMOTYP=0 Q
41C K PRCF(PMOTYP) D BATCH
42 S PRCF(PMOTYP)=0,PCOUNT=$S($D(^PRCF(423.9,PTYP,0)):$P(^(0),"^",3),1:"") S:+PCOUNT=0 PCOUNT=100
43 S PRIO=0 F PRCFL=1:1 S PRIO=$O(^TMP("PRCF-BATCH",$J,PMOTYP,PRIO)) Q:'PRIO D D
44 D:"1,2,3,4,9,10,12"[PTYP CREATE K PRCFL S PRIO=0 Q
45D 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)=""
46 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
47 K PRCFK,^TMP($J,"PCODE") Q
48E N PCODE,PTRAN
49 S PCODE=$G(^PRCF(423,DA,"CODE",1,0)),PTRAN=$G(^PRCF(423,DA,"TRANS"))
50 S PRCF("CSDA")=DA I $D(PRCF(PMOTYP))[0 S PRCF(PMOTYP)=0 D BATCH
51 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
52 I +PRCF(PMOTYP)>0 D
53 .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
54 .QUIT
55 S:"960.00,960.01,960.02,960.26,960.30,960.81"[$E(PCODE,9,14) CYCLE=1
56 I PRCF(PMOTYP)'<PCOUNT D:"1,2,3,4,9,10,12"[PTYP CREATE D BATCH S (CYCLE,PRCF(PMOTYP))=0
57 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
58 S X=Y S:'$D(PDATE) PDATE=0 S:X>PDATE PDATE=X
59 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)=""
60 S PRCF(PMOTYP)=PRCF(PMOTYP)+1 Q
Note: See TracBrowser for help on using the repository browser.