- SDWLRP1 ;;IOFO BAY PINES/TEH - WAITING LIST - RPC;06/28/2002 ; 26 Aug 2002 1:25 PM ; Compiled April 16, 2007 10:15:05
- ;;5.3;scheduling;**263,273,485,497,446,611**;AUG 13 1993;Build 9
- ;
- ;
- ;******************************************************************
- ; CHANGE LOG
- ;
- ; DATE PATCH DESCRIPTION
- ; ---- ----- -----------
- ; 2/21/03 SD*5.3*273 Line new+12 added "/"
- ; 5/10/06 SD*5.3*446 New field: INTRA-transfer
- ; 1/14/14 SD*5.3*611 Removed variables SDWLDUZ,SDWLDFN,SDWLDA from kill command
- OUTPUT(SDWLOUT,SDWLDFN) ;-FULL
- ; input:
- ; DFN = Patient
- ; Lookup uses Wait List data file (409.3) and returns the following data.
- ;
- ; output:
- ; SCOUT = location of data = ^TMP("SDWLG",$J,i,0)
- ; for i=1:number of records returned:
- ;
- ; Field Location Description
- ; 1 2 ORIGINATION DATE
- ; 2 3 INSTITUTION
- ; 3 4 CLINIC
- ; 4 5 WAIT LIST TYPE
- ; 5 6 SPECIFIC TEAM
- ; 5.1 22 MARKED OPEN (SPECIFIC TEAM)
- ; 6 7 SPECIFIC POSITION
- ; 6.1 23 MARKED OPEN (SPEICIFIC POSITION)
- ; 7 8 SERVICE /SPECIALTY
- ; 8 9 SPECIFIC CLINIC
- ; 9 10 ORIGINATING USER
- ; 10 11 PRIORITY
- ; 11 12 REQUESTED BY
- ; 12 13 PROVIDER
- ; 22 16 DESIRED DATE OF APPT
- ; 23 17 CURRENT STATUS
- ; 25 18 COMMENTS
- ; 27 20 NEW ENROLLE
- ;
- ; Reference/ICR
- ; Registration/4943
- ;
- N DIERR,SDWLDAX
- I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
- S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
- .S SDWLDAX="`"_SDWLDA
- .D FIND^DIC(409.3,,".01;1;2;3;4;5;5.1;6;6.1;7;8;9;10;11;12;15;22;23;25","PS",.SDWLDAX)
- I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
- K SDWLOUT S SDWLOUT=$NA(^TMP("DILIST",$J))
- Q
- OUTPUT1(SDWLOUT,SDWLDFN) ;
- ;Brief Output - for Wait List.
- ; input:
- ; DFN = Patient
- ; Lookup uses Wait List data file (409.3) and returns the following data.
- ;
- ; output:
- ; SWDLRES = On/Not on Wait list^Number of IENs^IEN;IEN;IEN;IEN.....
- ; 1 0 ^ 2 ^1;2
- ;
- S SDWLCNT=0,SDWLIEN=""
- I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=$NA(^TMP("SDWLRP1",$J)),^TMP("SDWLRP1",$J,1)=-1
- S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
- .I $P(^SDWL(409.3,SDWLDA,0),U,17)["C" Q
- .S SDWLCNT=SDWLCNT+1
- .S ^TMP("SDWLRP1",$J,SDWLCNT)=SDWLDA_"^"_$G(^SDWL(409.3,SDWLDA,0))
- S SDWLOUT=$NA(^TMP("SDWLRP1",$J))
- K SDWLDFN,SDWLDA,SDWLCNT,SDWLIEN
- Q
- OUTPUT3(SDWLOUT,SDWLDFN) ;Disposition Data
- ; input:
- ; DFN = Patient Internal ID
- ;
- ; output: Subscript 'DIS'
- ; Date Dispositioned^Disposition by^Disposition
- ;
- N SDWLRES,SDWLDFN,SDWLDA,DIERR
- I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
- S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
- .S SDWLDAX="`"_SDWLDA
- .D FIND^DIC(409.3,,"19;20;21","PS",.SDWLDAX)
- I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
- K SDWLOUT S SDWLOUT="^TMP(""DILIST"","_$J_")",SDWLRES=1
- Q
- INPUT(SDWLRES,SDWLSTR) ;
- ; Input:
- ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
- ; (R) = Required Field
- ; (O) = Optional
- ;
- ; .01 2 3 5 6
- ; DFN (R)^TYPE (R)^SPECIFIC TEAM (O)^SPECIFIC POSITION (O)^ORGINATING USER (R)^COMMENT (O)^CLINIC (O)^INTRA FLAG (O)^REJ FLAG (O)^MULTI TEAM FLAG (O)
- ; 1 2 3 4 5 6 7 8 9 10
- ;
- ; Output:
- ; SDWLRES = 0 Failed
- ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
- ;
- N DIERR,%H,SDWLF,SDWLFLD,SDWLFLG,SDWLI,SDWLIN,SDWLMSG,SDWLRNED,SDWLTP,SDWLVAL,SDWLX,SDWLY,X,Y
- K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J)
- I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
- D NEW
- D FDA I SDWLRES<0 D DEL Q
- ;D VAL I SDWLRES<0 D DEL Q
- D SET I SDWLRES<0 D DEL Q
- D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
- ; SD*5.3*611 stops variables SDWLDUZ,SDWLDFN,SDWLDA from being killed until END^SDWLE113
- K Y
- Q
- NEW ;Get IEN from ^SDWL(409.3,IEN,0).
- N DA,DIC,DIE,DIK,DR,SDREJ,SDINTRA,SDMULTI
- I $P(SDWLSTR,U,4) D
- .S SDWLTP=+$P(SDWLSTR,U,4)
- .S SDWLIN=$P($G(^SCTM(404.51,+$P(^SCTM(404.57,SDWLTP,0),U,2),0)),U,7)
- I $P(SDWLSTR,U,3) D
- .S SDWLIN=$P($G(^SCTM(404.51,+$P(SDWLSTR,U,3),0)),U,7)
- S SDWLDFN=+$P(SDWLSTR,U,1)
- S SDREJ=$P(SDWLSTR,U,9),SDINTRA=$P(SDWLSTR,U,8),SDMULTI=$P(SDWLSTR,U,10)
- ;identify INTRA-transfer
- ;- last team assignment
- S DIC(0)="LX",X=$P(SDWLSTR,U,1),DIC="^SDWL(409.3," D FILE^DICN I Y<0 S SDWLRES="-1^IEN failed" Q
- S SDWLDFN=$P(Y,U,2),SDWLDA=+Y,SDWLDUZ=$P(SDWLSTR,U,9)
- S DIE="^SDWL(409.3,",DA=SDWLDA
- S DR="1///^S X=DT" D ^DIE
- S DR="2////^S X=SDWLIN;32////^S X=SDREJ;34////^S X=SDINTRA;38////^S X=SDMULTI" D ^DIE
- S DR="23///^S X=""O""",DIE="^SDWL(409.3," D ^DIE
- ;
- ;DETERMINE ENROLLEE STATUS
- ;
- ;SDWLE=1 = NEW ENROLLEE
- ;SDWLE=2 = ESTABLISHED
- ;SDWLE=3 = PRIOR ENROLLEE
- ;SDWLE=4 = UNDETERMINED
- ;
- S SDWLDE=+$H,SDWLE=0,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1
- G SB0:SDWLE=2
- S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3)
- I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS,SDWLDB=2 I SDWLDET<366 S SDWLE=1
- I $D(SDWLDET),SDWLDET>365 S SDWLE=3
- I 'SDWLRNE S SDWLE=4
- SB0 I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
- .I 'SDWLRNE,SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
- .I 'SDWLEE S SDWLE=4 Q
- S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
- ;-Code here for filling in 409.3
- S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
- S DR="9////^S X=DUZ" D ^DIE
- S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
- S DR="27.2////^S X=SDWLDB" D ^DIE
- K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE
- Q
- SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDB S SDWLE=3 Q
- S SDWLX="" F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D
- .S SDWLY=$P($G(^DGCN(391.91,SDWLX,0)),U,2,3) D
- ..;CHECK FOR TREATING FACILITY
- ..I $$TF^XUAF4(+$P(SDWLY,U)) D
- ...;SORT FOR LAST TREATMENT DATE
- ...S SDWLD=$P(SDWLY,U,2) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
- I '$D(SDWLDTF) Q
- S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLD,X)=9999999-SDWLDTF D H^%DTC S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2
- I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
- K SDWLDTF
- Q
- FDA ;Get data from SDWLSTR string and set FDA.
- S SDWLF=409.3
- S SDWLVAL="" F SDWLI=2:1:7 S SDWLVAL=$P(SDWLSTR,"^",SDWLI) D
- .S SDWLFLD=SDWLI D
- ..S SDWLFLD=$S(SDWLFLD=2:4,SDWLFLD=3:5,SDWLFLD=4:6,SDWLFLD=5:9,SDWLFLD=7:15,1:25)
- .S SDWLFLG="F",SDWLIEN=$$IENS^DILF(SDWLDA) ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
- .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
- .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
- .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
- Q
- VAL ;Validate fields
- N DIERR
- D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
- I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
- M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
- Q
- SET ;Input data to file ^SDWL(409.3,IEN,0).
- D UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
- I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
- S SDWLRES=1_"^"_$G(SDWLDA)
- Q
- DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK
- S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
- Q
- INPUTDP(SDWLRES,SDWLSTR) ;Set disposition in Wait List Patient file
- ;
- ; Input:
- ;
- ; SDWLSTR=Patient DFN^Disposition^User DUZ^Wait List IEN
- ;
- ; Ouput:
- ;
- ; SDWLRES=-1 Failed
- ; SDWKRES=1^IEN for Wait List File (409.3)
- ;
- N SDWLDFN,SDWLDISP,SDWLDUZ,SDWLDA,SDWLDDT
- I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
- I '$G(^SDWL(409.3,SDWLDA,0)) S SDWLRES="-1^Missing Patient IEN" Q
- I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES="-1^Missing Wait List data file" Q
- D FDA1 I SDWLRES<0 D DEL1 Q
- D VAL1 I SDWLRES<0 D DEL1 Q
- D SET1 I SDWLRES<0 D DEL1 Q
- D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
- Q
- FDA1 ;
- S SDWLDFN=$P(SDWLSTR,U,1),SDWLDISP=$P(SDWLSTR,U,2),SDWLDUZ=$P(SDWLSTR,U,3),SDWLDA=$P(SDWLSTR,U,4),SDWLDDT=DT
- S SDWLIEN=$$IENS^DILF(SDWLDA)
- F SDWLI=1:1:4 S SDWLVAL=$S(SDWLI=1:SDWLDISP,SDWLI=2:SDWLDUZ,SDWLI=3:SDWLDDT,SDWLI=4:"C"),SDWLFLD=$S(SDWLI=1:21,SDWLI=2:20,SDWLI=3:19,SDWLI=4:23) D
- .S SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
- .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
- .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
- .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
- Q
- VAL1 ;
- N DIERR
- D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
- I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
- M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
- Q
- SET1 ;
- D UPDATE^DIE(,"^TMP(""SDWLOUT"",$J)","SDWLMSG")
- I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
- S SDWLRES=1
- Q
- DEL1 ;
- S DA(1)=SDWLDA,DIK="^SDWL("_DA(1)_",""DIS""," F DA=19,20,21,23 D ^DIK
- S SDWLRES="-1^"_"Disposition Nodes Deleted."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLRP1 10224 printed Jan 18, 2025@04:04:23 Page 2
- SDWLRP1 ;;IOFO BAY PINES/TEH - WAITING LIST - RPC;06/28/2002 ; 26 Aug 2002 1:25 PM ; Compiled April 16, 2007 10:15:05
- +1 ;;5.3;scheduling;**263,273,485,497,446,611**;AUG 13 1993;Build 9
- +2 ;
- +3 ;
- +4 ;******************************************************************
- +5 ; CHANGE LOG
- +6 ;
- +7 ; DATE PATCH DESCRIPTION
- +8 ; ---- ----- -----------
- +9 ; 2/21/03 SD*5.3*273 Line new+12 added "/"
- +10 ; 5/10/06 SD*5.3*446 New field: INTRA-transfer
- +11 ; 1/14/14 SD*5.3*611 Removed variables SDWLDUZ,SDWLDFN,SDWLDA from kill command
- OUTPUT(SDWLOUT,SDWLDFN) ;-FULL
- +1 ; input:
- +2 ; DFN = Patient
- +3 ; Lookup uses Wait List data file (409.3) and returns the following data.
- +4 ;
- +5 ; output:
- +6 ; SCOUT = location of data = ^TMP("SDWLG",$J,i,0)
- +7 ; for i=1:number of records returned:
- +8 ;
- +9 ; Field Location Description
- +10 ; 1 2 ORIGINATION DATE
- +11 ; 2 3 INSTITUTION
- +12 ; 3 4 CLINIC
- +13 ; 4 5 WAIT LIST TYPE
- +14 ; 5 6 SPECIFIC TEAM
- +15 ; 5.1 22 MARKED OPEN (SPECIFIC TEAM)
- +16 ; 6 7 SPECIFIC POSITION
- +17 ; 6.1 23 MARKED OPEN (SPEICIFIC POSITION)
- +18 ; 7 8 SERVICE /SPECIALTY
- +19 ; 8 9 SPECIFIC CLINIC
- +20 ; 9 10 ORIGINATING USER
- +21 ; 10 11 PRIORITY
- +22 ; 11 12 REQUESTED BY
- +23 ; 12 13 PROVIDER
- +24 ; 22 16 DESIRED DATE OF APPT
- +25 ; 23 17 CURRENT STATUS
- +26 ; 25 18 COMMENTS
- +27 ; 27 20 NEW ENROLLE
- +28 ;
- +29 ; Reference/ICR
- +30 ; Registration/4943
- +31 ;
- +32 NEW DIERR,SDWLDAX
- +33 ;- No Entry in Wait List file.
- IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
- SET SDWLRES=-1
- QUIT
- +34 SET SDWLDA=""
- FOR
- SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
- if SDWLDA<1
- QUIT
- Begin DoDot:1
- +35 SET SDWLDAX="`"_SDWLDA
- +36 DO FIND^DIC(409.3,,".01;1;2;3;4;5;5.1;6;6.1;7;8;9;10;11;12;15;22;23;25","PS",.SDWLDAX)
- End DoDot:1
- +37 IF $GET(DIERR)
- DO CLEAN^DILF
- SET SDWLRES=-1
- QUIT
- +38 KILL SDWLOUT
- SET SDWLOUT=$NAME(^TMP("DILIST",$JOB))
- +39 QUIT
- OUTPUT1(SDWLOUT,SDWLDFN) ;
- +1 ;Brief Output - for Wait List.
- +2 ; input:
- +3 ; DFN = Patient
- +4 ; Lookup uses Wait List data file (409.3) and returns the following data.
- +5 ;
- +6 ; output:
- +7 ; SWDLRES = On/Not on Wait list^Number of IENs^IEN;IEN;IEN;IEN.....
- +8 ; 1 0 ^ 2 ^1;2
- +9 ;
- +10 SET SDWLCNT=0
- SET SDWLIEN=""
- +11 IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
- SET SDWLRES=$NAME(^TMP("SDWLRP1",$JOB))
- SET ^TMP("SDWLRP1",$JOB,1)=-1
- +12 SET SDWLDA=""
- FOR
- SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
- if SDWLDA<1
- QUIT
- Begin DoDot:1
- +13 IF $PIECE(^SDWL(409.3,SDWLDA,0),U,17)["C"
- QUIT
- +14 SET SDWLCNT=SDWLCNT+1
- +15 SET ^TMP("SDWLRP1",$JOB,SDWLCNT)=SDWLDA_"^"_$GET(^SDWL(409.3,SDWLDA,0))
- End DoDot:1
- +16 SET SDWLOUT=$NAME(^TMP("SDWLRP1",$JOB))
- +17 KILL SDWLDFN,SDWLDA,SDWLCNT,SDWLIEN
- +18 QUIT
- OUTPUT3(SDWLOUT,SDWLDFN) ;Disposition Data
- +1 ; input:
- +2 ; DFN = Patient Internal ID
- +3 ;
- +4 ; output: Subscript 'DIS'
- +5 ; Date Dispositioned^Disposition by^Disposition
- +6 ;
- +7 NEW SDWLRES,SDWLDFN,SDWLDA,DIERR
- +8 ;- No Entry in Wait List file.
- IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
- SET SDWLRES=-1
- QUIT
- +9 SET SDWLDA=""
- FOR
- SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
- if SDWLDA<1
- QUIT
- Begin DoDot:1
- +10 SET SDWLDAX="`"_SDWLDA
- +11 DO FIND^DIC(409.3,,"19;20;21","PS",.SDWLDAX)
- End DoDot:1
- +12 IF $GET(DIERR)
- DO CLEAN^DILF
- SET SDWLRES=-1
- QUIT
- +13 KILL SDWLOUT
- SET SDWLOUT="^TMP(""DILIST"","_$JOB_")"
- SET SDWLRES=1
- +14 QUIT
- INPUT(SDWLRES,SDWLSTR) ;
- +1 ; Input:
- +2 ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
- +3 ; (R) = Required Field
- +4 ; (O) = Optional
- +5 ;
- +6 ; .01 2 3 5 6
- +7 ; DFN (R)^TYPE (R)^SPECIFIC TEAM (O)^SPECIFIC POSITION (O)^ORGINATING USER (R)^COMMENT (O)^CLINIC (O)^INTRA FLAG (O)^REJ FLAG (O)^MULTI TEAM FLAG (O)
- +8 ; 1 2 3 4 5 6 7 8 9 10
- +9 ;
- +10 ; Output:
- +11 ; SDWLRES = 0 Failed
- +12 ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
- +13 ;
- +14 NEW DIERR,%H,SDWLF,SDWLFLD,SDWLFLG,SDWLI,SDWLIN,SDWLMSG,SDWLRNED,SDWLTP,SDWLVAL,SDWLX,SDWLY,X,Y
- +15 KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB),^TMP("DIERR",$JOB)
- +16 IF '$GET(SDWLSTR)
- SET SDWLRES="-1^Data String Missing"
- QUIT
- +17 DO NEW
- +18 DO FDA
- IF SDWLRES<0
- DO DEL
- QUIT
- +19 ;D VAL I SDWLRES<0 D DEL Q
- +20 DO SET
- IF SDWLRES<0
- DO DEL
- QUIT
- +21 DO CLEAN^DILF
- KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB)
- +22 ; SD*5.3*611 stops variables SDWLDUZ,SDWLDFN,SDWLDA from being killed until END^SDWLE113
- +23 KILL Y
- +24 QUIT
- NEW ;Get IEN from ^SDWL(409.3,IEN,0).
- +1 NEW DA,DIC,DIE,DIK,DR,SDREJ,SDINTRA,SDMULTI
- +2 IF $PIECE(SDWLSTR,U,4)
- Begin DoDot:1
- +3 SET SDWLTP=+$PIECE(SDWLSTR,U,4)
- +4 SET SDWLIN=$PIECE($GET(^SCTM(404.51,+$PIECE(^SCTM(404.57,SDWLTP,0),U,2),0)),U,7)
- End DoDot:1
- +5 IF $PIECE(SDWLSTR,U,3)
- Begin DoDot:1
- +6 SET SDWLIN=$PIECE($GET(^SCTM(404.51,+$PIECE(SDWLSTR,U,3),0)),U,7)
- End DoDot:1
- +7 SET SDWLDFN=+$PIECE(SDWLSTR,U,1)
- +8 SET SDREJ=$PIECE(SDWLSTR,U,9)
- SET SDINTRA=$PIECE(SDWLSTR,U,8)
- SET SDMULTI=$PIECE(SDWLSTR,U,10)
- +9 ;identify INTRA-transfer
- +10 ;- last team assignment
- +11 SET DIC(0)="LX"
- SET X=$PIECE(SDWLSTR,U,1)
- SET DIC="^SDWL(409.3,"
- DO FILE^DICN
- IF Y<0
- SET SDWLRES="-1^IEN failed"
- QUIT
- +12 SET SDWLDFN=$PIECE(Y,U,2)
- SET SDWLDA=+Y
- SET SDWLDUZ=$PIECE(SDWLSTR,U,9)
- +13 SET DIE="^SDWL(409.3,"
- SET DA=SDWLDA
- +14 SET DR="1///^S X=DT"
- DO ^DIE
- +15 SET DR="2////^S X=SDWLIN;32////^S X=SDREJ;34////^S X=SDINTRA;38////^S X=SDMULTI"
- DO ^DIE
- +16 SET DR="23///^S X=""O"""
- SET DIE="^SDWL(409.3,"
- DO ^DIE
- +17 ;
- +18 ;DETERMINE ENROLLEE STATUS
- +19 ;
- +20 ;SDWLE=1 = NEW ENROLLEE
- +21 ;SDWLE=2 = ESTABLISHED
- +22 ;SDWLE=3 = PRIOR ENROLLEE
- +23 ;SDWLE=4 = UNDETERMINED
- +24 ;
- +25 SET SDWLDE=+$HOROLOG
- SET SDWLE=0
- SET (SDWLEE,SDWLRNED,SDWLDB)=0
- DO SB1
- +26 if SDWLE=2
- GOTO SB0
- +27 SET SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN)
- if $PIECE(SDWLRNE,U,4)="A"
- GOTO SB0
- SET SDWLRNED=$PIECE(SDWLRNE,U,3)
- +28 IF SDWLRNED
- SET X=SDWLRNED
- DO H^%DTC
- SET SDWLDS=%H
- SET SDWLDE=+$HOROLOG
- SET SDWLDET=SDWLDE-SDWLDS
- SET SDWLDB=2
- IF SDWLDET<366
- SET SDWLE=1
- +29 IF $DATA(SDWLDET)
- IF SDWLDET>365
- SET SDWLE=3
- +30 IF 'SDWLRNE
- SET SDWLE=4
- SB0 IF $DATA(SDWLRNE)
- IF $PIECE(SDWLRNE,U,4)="A"
- Begin DoDot:1
- +1 IF 'SDWLRNE
- IF SDWLEE>730!(SDWLEE=730)
- SET SDWLE=4
- QUIT
- +2 IF 'SDWLEE
- SET SDWLE=4
- QUIT
- End DoDot:1
- +3 SET SDWLRNE=$SELECT(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
- +4 ;-Code here for filling in 409.3
- +5 SET DR="27////^S X=SDWLRNE"
- SET DIE="^SDWL(409.3,"
- SET DA=SDWLDA
- DO ^DIE
- +6 SET DR="9////^S X=DUZ"
- DO ^DIE
- +7 SET DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")"
- DO ^DIE
- +8 SET DR="27.2////^S X=SDWLDB"
- DO ^DIE
- +9 KILL SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE
- +10 QUIT
- SB1 IF '$DATA(^DGCN(391.91,"B",SDWLDFN))
- NEW SDWLDB
- SET SDWLE=3
- QUIT
- +1 SET SDWLX=""
- FOR
- SET SDWLX=$ORDER(^DGCN(391.91,"B",SDWLDFN,SDWLX))
- if SDWLX=""
- QUIT
- Begin DoDot:1
- +2 SET SDWLY=$PIECE($GET(^DGCN(391.91,SDWLX,0)),U,2,3)
- Begin DoDot:2
- +3 ;CHECK FOR TREATING FACILITY
- +4 IF $$TF^XUAF4(+$PIECE(SDWLY,U))
- Begin DoDot:3
- +5 ;SORT FOR LAST TREATMENT DATE
- +6 SET SDWLD=$PIECE(SDWLY,U,2)
- IF SDWLD
- SET SDWLDTF(9999999-SDWLD)=SDWLX
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +7 IF '$DATA(SDWLDTF)
- QUIT
- +8 SET SDWLDTF=$ORDER(SDWLDTF(0))
- IF SDWLDTF
- SET (SDWLD,X)=9999999-SDWLDTF
- DO H^%DTC
- SET SDWLEE=SDWLDE-%H
- SET SDWLDB=1
- IF SDWLEE<730
- SET SDWLE=2
- +9 IF $DATA(SDWLEE)
- IF SDWLEE>730!(SDWLEE=730)
- SET SDWLE=3
- +10 KILL SDWLDTF
- +11 QUIT
- FDA ;Get data from SDWLSTR string and set FDA.
- +1 SET SDWLF=409.3
- +2 SET SDWLVAL=""
- FOR SDWLI=2:1:7
- SET SDWLVAL=$PIECE(SDWLSTR,"^",SDWLI)
- Begin DoDot:1
- +3 SET SDWLFLD=SDWLI
- Begin DoDot:2
- +4 SET SDWLFLD=$SELECT(SDWLFLD=2:4,SDWLFLD=3:5,SDWLFLD=4:6,SDWLFLD=5:9,SDWLFLD=7:15,1:25)
- End DoDot:2
- +5 ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
- SET SDWLFLG="F"
- SET SDWLIEN=$$IENS^DILF(SDWLDA)
- +6 IF $DATA(SDWLMSG)
- MERGE SDWLRES=SDWLMSG
- SET SDWLRES=-1
- QUIT
- +7 DO FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
- +8 SET SDWLRES=1
- MERGE SDWLRES("SDWLIN")=^TMP("SDWLIN",$JOB)
- End DoDot:1
- +9 QUIT
- VAL ;Validate fields
- +1 NEW DIERR
- +2 DO VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
- +3 IF $GET(SDWLMSG("DIERR"))
- SET SDWLRES=-1
- QUIT
- +4 MERGE SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$JOB)
- +5 QUIT
- SET ;Input data to file ^SDWL(409.3,IEN,0).
- +1 DO UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
- +2 IF $GET(SDWLMSG("DIERR"))
- SET SDWLRES=-1
- QUIT
- +3 SET SDWLRES=1_"^"_$GET(SDWLDA)
- +4 QUIT
- DEL SET DA=SDWLDA
- SET DIK="^SDWL(409.3,"
- DO ^DIK
- +1 SET SDWLRES="-1^Entry "_SDWLDA_" Deleted"
- +2 QUIT
- INPUTDP(SDWLRES,SDWLSTR) ;Set disposition in Wait List Patient file
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; SDWLSTR=Patient DFN^Disposition^User DUZ^Wait List IEN
- +5 ;
- +6 ; Ouput:
- +7 ;
- +8 ; SDWLRES=-1 Failed
- +9 ; SDWKRES=1^IEN for Wait List File (409.3)
- +10 ;
- +11 NEW SDWLDFN,SDWLDISP,SDWLDUZ,SDWLDA,SDWLDDT
- +12 IF '$GET(SDWLSTR)
- SET SDWLRES="-1^Data String Missing"
- QUIT
- +13 IF '$GET(^SDWL(409.3,SDWLDA,0))
- SET SDWLRES="-1^Missing Patient IEN"
- QUIT
- +14 IF '$DATA(^SDWL(409.3,"B",SDWLDFN))
- SET SDWLRES="-1^Missing Wait List data file"
- QUIT
- +15 DO FDA1
- IF SDWLRES<0
- DO DEL1
- QUIT
- +16 DO VAL1
- IF SDWLRES<0
- DO DEL1
- QUIT
- +17 DO SET1
- IF SDWLRES<0
- DO DEL1
- QUIT
- +18 DO CLEAN^DILF
- KILL ^TMP("SDWLIN",$JOB),^TMP("SDWLOUT",$JOB)
- +19 QUIT
- FDA1 ;
- +1 SET SDWLDFN=$PIECE(SDWLSTR,U,1)
- SET SDWLDISP=$PIECE(SDWLSTR,U,2)
- SET SDWLDUZ=$PIECE(SDWLSTR,U,3)
- SET SDWLDA=$PIECE(SDWLSTR,U,4)
- SET SDWLDDT=DT
- +2 SET SDWLIEN=$$IENS^DILF(SDWLDA)
- +3 FOR SDWLI=1:1:4
- SET SDWLVAL=$SELECT(SDWLI=1:SDWLDISP,SDWLI=2:SDWLDUZ,SDWLI=3:SDWLDDT,SDWLI=4:"C")
- SET SDWLFLD=$SELECT(SDWLI=1:21,SDWLI=2:20,SDWLI=3:19,SDWLI=4:23)
- Begin DoDot:1
- +4 SET SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
- +5 IF $DATA(SDWLMSG)
- MERGE SDWLRES=SDWLMSG
- SET SDWLRES=-1
- QUIT
- +6 DO FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
- +7 SET SDWLRES=1
- MERGE SDWLRES("SDWLIN")=^TMP("SDWLIN",$JOB)
- End DoDot:1
- +8 QUIT
- VAL1 ;
- +1 NEW DIERR
- +2 DO VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
- +3 IF $GET(SDWLMSG("DIERR"))
- SET SDWLRES=-1
- QUIT
- +4 MERGE SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$JOB)
- +5 QUIT
- SET1 ;
- +1 DO UPDATE^DIE(,"^TMP(""SDWLOUT"",$J)","SDWLMSG")
- +2 IF $GET(SDWLMSG("DIERR"))
- SET SDWLRES=-1
- QUIT
- +3 SET SDWLRES=1
- +4 QUIT
- DEL1 ;
- +1 SET DA(1)=SDWLDA
- SET DIK="^SDWL("_DA(1)_",""DIS"","
- FOR DA=19,20,21,23
- DO ^DIK
- +2 SET SDWLRES="-1^"_"Disposition Nodes Deleted."
- +3 QUIT