source: WorldVistAEHR/trunk/r/PAID-PRS/PRSDFOLL.m

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1PRSDFOLL ;HISC/GWB-FOLLOWUP CODE DOWNLOAD PROCESSING ;9-MAR-1998
2 ;;4.0;PAID;**35**;Sep 21, 1995
3 I (DBNAME="MXFLCD-1")!(DBNAME="MXFLYD-1") D INITFU
4 Q:($E(DATA,1,2)=" ")!($E(DATA,1,2)="00")
5 S (FLD,NODE,P)="",F=$E(DATA,1,2),FD=$E(DATA,3,10)
6 I F="DT" S DATA=F,NODE=3,PIECE=17,FLDNUM=115.17 G EXIT
7 I (F="AL")!($E(F)="L")!(F="01")!(F="02")!(F="03")!(F="04")!(F="05")!(F="06")!(F="07")!(F="08")!(F="09")!(F=10)!(F=11)!(F=12)!(F=13)!(F=14) S NODE=2 G NODE
8 I (F=15)!(F=16)!(F=17)!(F=18)!(F=19)!(F=20)!(F=21)!(F=22)!(F=23)!(F=24)!(F=25)!(F=26)!(F=27)!(F=28)!(F=29)!(F=51) S NODE=2 G NODE
9 I (F="AI")!(F="DE")!(F="EM")!(F="FP")!(F="NM")!(F="OG")!(F="OP")!(F="OS")!(F="PM")!(F="PS")!(F="SU")!(F="TS")!(F="UR")!(F="CS")!(F="RR")!($E(F)="S")!(F="DT")!(F=52)!(F="CR")!(F="IM")!(F="MG")!(F="PN")!(F=53) S NODE=3 G NODE
10 I F>29,F<50 S NODE=4
11NODE I NODE="" Q
12 D:NODE=2 NODE2
13 D:NODE=3 NODE3
14 D:NODE=4 NODE4
15 S PIECE=P,FLDNUM=FLD
16 I $E(F)="L" D
17 . ; compute date for expiration of licensure
18 . S L=$E(F,2),EXYR=$E(FD,1,4),EXMD=$E(FD,5,8)
19 . ; ensure resulting date will be valid if date is a leap day
20 . I EXMD="0229",'$$LEAPYR^PRSLIB00(EXYR+L) S EXMD="0228"
21 . S FD=EXYR+L_EXMD
22 S DATA=FD D DATE^PRSDUTIL
23 S:F="DT" DATA=F
24EXIT K EXMD,EXYR,F,FD,FLD,L,P Q
25NODE2 S P=$S(F="AL":1,$E(F)="L":2,F="01":3,F="02":4,F="03":5,F="04":6,F="05":7,F="06":8,F="07":9,F="09":10,F=14:11,F=16:12,F=17:13,F=18:14,F=19:15,F=20:16,F=21:17,F=22:18,F=23:19,F=24:20,F=25:21,F=26:22,F=27:23,F=28:24,F=29:25,F=51:26,1:"")
26 S:P="" P=$S(F="08":27,F=10:28,F=11:29,F=12:30,F=13:31,F=15:32,1:"")
27 S FLD=$S(P=1:89,P=2:90,P=3:91,P=4:92,P=5:93,P=6:94,P=7:95,P=8:96,P=9:97,P=10:98,P=11:99,P=12:100,P=13:101,P=14:102,P=15:103,P=16:104,P=17:105,P=18:106,P=19:107,P=20:108,P=21:109,P=22:110,P=23:111,P=24:112,P=25:113,P=26:114,1:"")
28 S:FLD="" FLD=$S(P=27:97.1,P=28:98.1,P=29:98.2,P=30:98.3,P=31:98.4,P=32:99.1,1:"")
29 Q
30NODE3 S P=$S(F="AI":1,F="DE":2,F="EM":3,F="FP":4,F="NM":5,F="OG":6,F="OP":7,F="OS":8,F="PM":9,F="PS":10,F="SU":11,F="TS":12,F="UR":13,F="CS":14,F="RR":15,$E(F)="S":16,F="DT":17,F=52:18,F="CR":19,F="IM":20,F="MG":21,F="PN":22,F=53:23,1:PIECE)
31 S FLD=$S(P=1:115.01,P=2:115.02,P=3:115.03,P=4:115.04,P=5:115.05,P=6:115.06,P=7:115.07,P=8:115.08,P=9:115.09,P=10:115.1,P=11:115.11,P=12:115.12,P=13:115.13,P=14:115.14,P=15:115.15,P=16:115.16,P=17:115.17,P=18:114.1,1:"")
32 Q
33NODE4 S P=$S(F=30:1,F=31:2,F=32:3,F=33:4,F=34:5,F=35:6,F=36:7,F=37:8,F=38:9,F=39:10,F=40:11,F=41:12,F=42:13,F=43:14,F=44:15,F=45:16,F=46:17,F=47:18,F=48:19,F=49:20,1:PIECE)
34 S FLD=$S(P=1:116.01,P=2:116.02,P=3:116.03,P=4:116.04,P=5:116.05,P=6:116.06,P=7:116.07,P=8:116.08,P=9:116.09,P=10:116.1,P=11:116.11,P=12:116.12,P=13:116.13,P=14:116.14,P=15:116.15,P=16:116.16,P=17:116.17,P=18:116.18,P=19:116.19,P=20:116.2,1:"")
35 Q
36INITFU F FLDNUM=89:1:114,114.1,115.01:.01:115.17,116.01:.01:116.2 I $D(^DD(450,"IX",FLDNUM)) D KILXREF
37 K ^PRSPC(IEN,2),^PRSPC(IEN,3),^PRSPC(IEN,4)
38 K ADD,FLDNUM,FUNODE,FUPIECE,X Q
39KILXREF S ADD=$P(^DD(450,FLDNUM,0),U,4),FUNODE=$P(ADD,";",1),FUPIECE=$P(ADD,";",2) I $D(^PRSPC(IEN,FUNODE)) S X=$P(^PRSPC(IEN,FUNODE),U,FUPIECE) I X'="" S DA=IEN D KILL^PRSDXREF Q
Note: See TracBrowser for help on using the repository browser.