source: WorldVistAEHR/trunk/r/LIBRARY-LBR-LBRS/LBRYPPR.m

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1LBRYPPR ;ISC2/DJM-PREDICTION PATTERN ROUTINE ;[ 09/03/98 3:03 PM ]
2 ;;2.5;Library;**2,6**;Mar 11, 1996
3 ;
4START 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=""
7LDT S LBA1=$O(^LBRY(682,"A1",LBRYLOC,LBA1)) Q:LBA1'>0
8 S LBJD=""
9LBJ 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
12GET S LBNM="",LBRYPP0=^LBRY(680.9,LBRYPP,0),LBRYPP3=$G(^LBRY(680.9,LBRYPP,3))
13 S LBRYPP2=$G(^LBRY(680.9,LBRYPP,2))
14BEGIN 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
22TYPE 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
27DOM 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
30DOMA I LBEM<LBJDD S LBJDD=LBEM G TYPE1
31 S LBJDD=LBN G TYPE1
32TYPE1 S:$L(LBJDD)=1 LBJDD="0"_LBJDD S:$L(LBJDM)=1 LBJDM="0"_LBJDM
33 S LBJDT=LBJDY_LBJDM_LBJDD
34 G ^LBRYPPR0
35NXT0 S LBY=$P(LBRYPP0,U,3),LBZ=LBMOZ
36NXT 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
40DOM1 S LBDOM=$P(LBRYPP0,U,5)
41 F I=2:1 S LBN=$P(LBDOM,",",I) G:LBN="" NXT0 G:LBN>LBJDD DOMA
42DOW 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
45DOW1 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
48FIND F I=2:1 S LBY1=$P(LBY,",",I) G:LBY1="" EXIT I LBX=LBY1 S LBZ=I K I,LBY1 Q
49 Q
50EXIT S LBZ="-1" K I,LBY1 Q
51NEXT 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
52EOM ; 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)
60EM2 ; 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
67NEWWK 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
68CONV 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
74ADD S WOM=$P(LBN,"/",1),LBJDD=LBJDD+(WOM-1*7) Q
75NEWM D NEWWK S LBY=$P(LBRYPP3,U),LBZ=1 D NEXT,CONV G TYPE1
76DOWA 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
79DOWX I LBYA=LBXA,LBYB=LBXB S LBZ=I Q
80 I LBYA>LBXA S LBZ=I Q
81 Q
82EF1 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
88ADDED 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
91ERROR1 Q
92ERROR2 Q
93ERROR3 Q
94ERROR4 Q
Note: See TracBrowser for help on using the repository browser.