PRSDFOLL ;HISC/GWB-FOLLOWUP CODE DOWNLOAD PROCESSING ;9-MAR-1998
;;4.0;PAID;**35**;Sep 21, 1995
I (DBNAME="MXFLCD-1")!(DBNAME="MXFLYD-1") D INITFU
Q:($E(DATA,1,2)=" ")!($E(DATA,1,2)="00")
S (FLD,NODE,P)="",F=$E(DATA,1,2),FD=$E(DATA,3,10)
I F="DT" S DATA=F,NODE=3,PIECE=17,FLDNUM=115.17 G EXIT
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
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
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
I F>29,F<50 S NODE=4
NODE I NODE="" Q
D:NODE=2 NODE2
D:NODE=3 NODE3
D:NODE=4 NODE4
S PIECE=P,FLDNUM=FLD
I $E(F)="L" D
. ; compute date for expiration of licensure
. S L=$E(F,2),EXYR=$E(FD,1,4),EXMD=$E(FD,5,8)
. ; ensure resulting date will be valid if date is a leap day
. I EXMD="0229",'$$LEAPYR^PRSLIB00(EXYR+L) S EXMD="0228"
. S FD=EXYR+L_EXMD
S DATA=FD D DATE^PRSDUTIL
S:F="DT" DATA=F
EXIT K EXMD,EXYR,F,FD,FLD,L,P Q
NODE2 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:"")
S:P="" P=$S(F="08":27,F=10:28,F=11:29,F=12:30,F=13:31,F=15:32,1:"")
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:"")
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:"")
Q
NODE3 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)
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:"")
Q
NODE4 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)
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:"")
Q
INITFU 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
K ^PRSPC(IEN,2),^PRSPC(IEN,3),^PRSPC(IEN,4)
K ADD,FLDNUM,FUNODE,FUPIECE,X Q
KILXREF 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDFOLL 3158 printed Dec 13, 2024@02:25:26 Page 2
PRSDFOLL ;HISC/GWB-FOLLOWUP CODE DOWNLOAD PROCESSING ;9-MAR-1998
+1 ;;4.0;PAID;**35**;Sep 21, 1995
+2 IF (DBNAME="MXFLCD-1")!(DBNAME="MXFLYD-1")
DO INITFU
+3 if ($EXTRACT(DATA,1,2)=" ")!($EXTRACT(DATA,1,2)="00")
QUIT
+4 SET (FLD,NODE,P)=""
SET F=$EXTRACT(DATA,1,2)
SET FD=$EXTRACT(DATA,3,10)
+5 IF F="DT"
SET DATA=F
SET NODE=3
SET PIECE=17
SET FLDNUM=115.17
GOTO EXIT
+6 IF (F="AL")!($EXTRACT(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)
SET NODE=2
GOTO NODE
+7 IF (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)
SET NODE=2
GOTO NODE
+8 IF (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")!($EXTRACT(F)="S")!(F="DT")!(F=52)!(F="CR")!(F="IM")!(F="MG")!(F="PN")!(F=53)
SET NODE=3
GOTO NODE
+9 IF F>29
IF F<50
SET NODE=4
NODE IF NODE=""
QUIT
+1 if NODE=2
DO NODE2
+2 if NODE=3
DO NODE3
+3 if NODE=4
DO NODE4
+4 SET PIECE=P
SET FLDNUM=FLD
+5 IF $EXTRACT(F)="L"
Begin DoDot:1
+6 ; compute date for expiration of licensure
+7 SET L=$EXTRACT(F,2)
SET EXYR=$EXTRACT(FD,1,4)
SET EXMD=$EXTRACT(FD,5,8)
+8 ; ensure resulting date will be valid if date is a leap day
+9 IF EXMD="0229"
IF '$$LEAPYR^PRSLIB00(EXYR+L)
SET EXMD="0228"
+10 SET FD=EXYR+L_EXMD
End DoDot:1
+11 SET DATA=FD
DO DATE^PRSDUTIL
+12 if F="DT"
SET DATA=F
EXIT KILL EXMD,EXYR,F,FD,FLD,L,P
QUIT
NODE2 SET P=$SELECT(F="AL":1,$EXTRACT(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:
"")
+1 if P=""
SET P=$SELECT(F="08":27,F=10:28,F=11:29,F=12:30,F=13:31,F=15:32,1:"")
+2 SET FLD=$SELECT(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:"")
+3 if FLD=""
SET FLD=$SELECT(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:"")
+4 QUIT
NODE3 SET P=$SELECT(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,$EXTRACT(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:PI
ECE)
+1 SET FLD=$SELECT(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:"")
+2 QUIT
NODE4 SET P=$SELECT(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)
+1 SET FLD=$SELECT(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:"")
+2 QUIT
INITFU FOR FLDNUM=89:1:114,114.1,115.01:.01:115.17,116.01:.01:116.2
IF $DATA(^DD(450,"IX",FLDNUM))
DO KILXREF
+1 KILL ^PRSPC(IEN,2),^PRSPC(IEN,3),^PRSPC(IEN,4)
+2 KILL ADD,FLDNUM,FUNODE,FUPIECE,X
QUIT
KILXREF SET ADD=$PIECE(^DD(450,FLDNUM,0),U,4)
SET FUNODE=$PIECE(ADD,";",1)
SET FUPIECE=$PIECE(ADD,";",2)
IF $DATA(^PRSPC(IEN,FUNODE))
SET X=$PIECE(^PRSPC(IEN,FUNODE),U,FUPIECE)
IF X'=""
SET DA=IEN
DO KILL^PRSDXREF
QUIT
