1 | LBRYPPR ;ISC2/DJM-PREDICTION PATTERN ROUTINE ;[ 09/03/98 3:03 PM ]
|
---|
2 | ;;2.5;Library;**2,6**;Mar 11, 1996
|
---|
3 | ;
|
---|
4 | START K LBRYEF1 S LBRYPP=$P(^LBRY(680.5,LBRYCLS,0),U,3) Q:LBRYPP="" S LBNM=""
|
---|
5 | I +LBRYPP'=LBRYPP!(LBRYPP<1) Q ;COULD NOT RESOLVE PREDICTION PATTERN, PLEASE INSERT
|
---|
6 | S LBA1=""
|
---|
7 | LDT S LBA1=$O(^LBRY(682,"A1",LBRYLOC,LBA1)) Q:LBA1'>0
|
---|
8 | S LBJD=""
|
---|
9 | LBJ S LBJD=$O(^LBRY(682,"A1",LBRYLOC,LBA1,LBJD)) G LDT:LBJD=""
|
---|
10 | S LBJD=$G(^LBRY(682,LBJD,1)) I $P(LBJD,U,8)="P" S LBJDT=$P(LBJD,U)
|
---|
11 | I $G(LBJDT)="" G LBJ
|
---|
12 | GET S LBNM="",LBRYPP0=^LBRY(680.9,LBRYPP,0),LBRYPP3=$G(^LBRY(680.9,LBRYPP,3))
|
---|
13 | S LBRYPP2=$G(^LBRY(680.9,LBRYPP,2))
|
---|
14 | BEGIN S X1=DT,X2=LBJDT
|
---|
15 | S PUD=$S($P(^LBRY(680,LBRYLOC,0),U,3)'="":$P(^(0),U,3),1:5)
|
---|
16 | D ^%DTC Q:X+PUD<0
|
---|
17 | S LBJDY=+$E(LBJDT,1,3),LBJDM=+$E(LBJDT,4,5),LBJDD=+$E(LBJDT,6,7)
|
---|
18 | S LBX=+LBJDM,LBY=$P(LBRYPP0,U,3) I LBX="" G ERROR1
|
---|
19 | D FIND G:LBZ>0 TYPE
|
---|
20 | S LBRYEF1=1
|
---|
21 | Q
|
---|
22 | TYPE S LBMOZ=LBZ G:$P(LBRYPP0,U,5)]"" DOM
|
---|
23 | G:$P(LBRYPP3,U)]"" DOW G:$P(LBRYPP0,U,4)]"" ADDED
|
---|
24 | D NEXT S LBNM=1 I $P(LBN,U,2)]"" S LBJDY=LBJDY+1
|
---|
25 | S LBN=+LBN S:$L(LBN)=1 LBN="0"_LBN S LBJDT=LBJDY_LBN_"00"
|
---|
26 | G ^LBRYPPR0
|
---|
27 | DOM S EM=LBJDM D EOM G:LBJDD=LBEM NXT S LBX=+LBJDD,LBY=$P(LBRYPP0,U,5)
|
---|
28 | I LBX="" G ERROR2
|
---|
29 | D FIND G:LBZ<1 DOM1 D NEXT G:$P(LBN,U,2)]"" NXT0 S LBJDD=LBN
|
---|
30 | DOMA I LBEM<LBJDD S LBJDD=LBEM G TYPE1
|
---|
31 | S LBJDD=LBN G TYPE1
|
---|
32 | TYPE1 S:$L(LBJDD)=1 LBJDD="0"_LBJDD S:$L(LBJDM)=1 LBJDM="0"_LBJDM
|
---|
33 | S LBJDT=LBJDY_LBJDM_LBJDD
|
---|
34 | G ^LBRYPPR0
|
---|
35 | NXT0 S LBY=$P(LBRYPP0,U,3),LBZ=LBMOZ
|
---|
36 | NXT D NEXT S:$P(LBN,U,2)]"" LBJDY=LBJDY+1 S (LBJDM,EM)=+LBN,LBNM=1
|
---|
37 | S LBJDD=$P($P(LBRYPP0,U,5),",",2) D EOM G:LBJDD'>LBEM TYPE1
|
---|
38 | S LBJDD=LBEM
|
---|
39 | G TYPE1
|
---|
40 | DOM1 S LBDOM=$P(LBRYPP0,U,5)
|
---|
41 | F I=2:1 S LBN=$P(LBDOM,",",I) G:LBN="" NXT0 G:LBN>LBJDD DOMA
|
---|
42 | DOW G:LBJDD=0 ERROR3 S X=LBJDT D DW^%DTC
|
---|
43 | S YY=LBJDD\7,YY=$S(LBJDD#7=0:YY,1:YY+1),LBX=YY_"/"_Y
|
---|
44 | S LBY=$P(LBRYPP3,U),EM=LBJDM D EOM,FIND S LBWKZ=LBZ G:LBZ<1 DOWA
|
---|
45 | DOW1 D NEXT D:$P(LBN,U,2)]"" NEWWK D CONV G:LBJDD'>LBEM TYPE1
|
---|
46 | G:$P($P(LBRYPP3,U),",",3)]"" NEWM S LBJDD=LBJDD-7 G TYPE1
|
---|
47 | Q
|
---|
48 | FIND F I=2:1 S LBY1=$P(LBY,",",I) G:LBY1="" EXIT I LBX=LBY1 S LBZ=I K I,LBY1 Q
|
---|
49 | Q
|
---|
50 | EXIT S LBZ="-1" K I,LBY1 Q
|
---|
51 | NEXT K LBN S LBN=$P(LBY,",",LBZ+1),LBZ=LBZ+1 Q:LBN]"" S LBZ=2,LBN=$P(LBY,",",LBZ),$P(LBN,U,2)=1 Q
|
---|
52 | EOM ; sets LBEM equal to number of days in the month
|
---|
53 | ; requires EM=month and LBJDY=FMan 3 digit year
|
---|
54 | ;
|
---|
55 | N LBRTEMP
|
---|
56 | ; LBRTEMP used to store the days of the month
|
---|
57 | S LBRTEMP="31^28^31^30^31^30^31^31^30^31^30^31"
|
---|
58 | ; extract months' total number of days
|
---|
59 | S LBEM=$P(LBRTEMP,U,EM)
|
---|
60 | EM2 ; if the month is February, check for leap years and centuries
|
---|
61 | I EM=2 D
|
---|
62 | . N YR
|
---|
63 | . S YR=LBJDY+1700
|
---|
64 | . I (((YR#4=0)&(YR#100'=0))!((YR#100=0)&(YR#400=0))) S LBEM=29
|
---|
65 | K EM
|
---|
66 | Q
|
---|
67 | NEWWK S NXTWK=LBN,LBY=$P(LBRYPP0,U,3),LBZ=LBMOZ D NEXT S:$P(LBN,U,2)]"" LBJDY=LBJDY+1 S (LBJDM,EM)=+LBN,LBNM=1,LBN=NXTWK D EOM Q
|
---|
68 | CONV S:$L(LBJDM)=1 LBJDM="0"_LBJDM
|
---|
69 | S LBN=$P(LBN,U),X=LBJDY_LBJDM_"01" D DW^%DTC
|
---|
70 | S FM=Y,LBRDOW=$P(LBN,"/",2)
|
---|
71 | I FM=LBRDOW S LBJDD=1 G ADD
|
---|
72 | I LBRDOW>FM S LBJDD=LBRDOW-FM+1 G ADD
|
---|
73 | S LBJDD=8+LBRDOW-FM
|
---|
74 | ADD S WOM=$P(LBN,"/",1),LBJDD=LBJDD+(WOM-1*7) Q
|
---|
75 | NEWM D NEWWK S LBY=$P(LBRYPP3,U),LBZ=1 D NEXT,CONV G TYPE1
|
---|
76 | DOWA S LBXA=$P(LBX,"/",1),LBXB=$P(LBX,"/",2) K LBZ
|
---|
77 | F I=2:1 S LBY1=$P(LBY,",",I) G:LBY1="" ERROR4
|
---|
78 | S LBYA=$P(LBY1,"/",1),LBYB=$P(LBY1,"/",2) D DOWX G:$D(LBZ) DOW1
|
---|
79 | DOWX I LBYA=LBXA,LBYB=LBXB S LBZ=I Q
|
---|
80 | I LBYA>LBXA S LBZ=I Q
|
---|
81 | Q
|
---|
82 | EF1 S Y=LBJDT X ^DD("DD")
|
---|
83 | W !!,"The last Journal Date, ",Y,", is not found in the PREDICTION PATTERN"
|
---|
84 | W !,"for this title. "
|
---|
85 | W "Use (E)dit to change the JOURNAL DATE to a valid month"
|
---|
86 | W !,"or change the ENTRY TYPE to INSERT." S XZ="CONTINUE//" D PAUSE^LBRYUTL
|
---|
87 | Q
|
---|
88 | ADDED S X1=LBJDT,X2=$P(LBRYPP0,U,4) D C^%DTC
|
---|
89 | S:$E(LBJDT,4,5)'=$E(X,4,5) LBNM=1 S LBJDT=X
|
---|
90 | G ^LBRYPPR0
|
---|
91 | ERROR1 Q
|
---|
92 | ERROR2 Q
|
---|
93 | ERROR3 Q
|
---|
94 | ERROR4 Q
|
---|