Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDWLRP1

SDWLRP1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. ;******************************************************************
  1. ; CHANGE LOG
  1. ;
  1. ; DATE PATCH DESCRIPTION
  1. ; ---- ----- -----------
  1. ; 2/21/03 SD*5.3*273 Line new+12 added "/"
  1. ; 5/10/06 SD*5.3*446 New field: INTRA-transfer
  1. ; 1/14/14 SD*5.3*611 Removed variables SDWLDUZ,SDWLDFN,SDWLDA from kill command
  1. OUTPUT(SDWLOUT,SDWLDFN) ;-FULL
  1. ; input:
  1. ; DFN = Patient
  1. ; Lookup uses Wait List data file (409.3) and returns the following data.
  1. ;
  1. ; output:
  1. ; SCOUT = location of data = ^TMP("SDWLG",$J,i,0)
  1. ; for i=1:number of records returned:
  1. ;
  1. ; Field Location Description
  1. ; 1 2 ORIGINATION DATE
  1. ; 2 3 INSTITUTION
  1. ; 3 4 CLINIC
  1. ; 4 5 WAIT LIST TYPE
  1. ; 5 6 SPECIFIC TEAM
  1. ; 5.1 22 MARKED OPEN (SPECIFIC TEAM)
  1. ; 6 7 SPECIFIC POSITION
  1. ; 6.1 23 MARKED OPEN (SPEICIFIC POSITION)
  1. ; 7 8 SERVICE /SPECIALTY
  1. ; 8 9 SPECIFIC CLINIC
  1. ; 9 10 ORIGINATING USER
  1. ; 10 11 PRIORITY
  1. ; 11 12 REQUESTED BY
  1. ; 12 13 PROVIDER
  1. ; 22 16 DESIRED DATE OF APPT
  1. ; 23 17 CURRENT STATUS
  1. ; 25 18 COMMENTS
  1. ; 27 20 NEW ENROLLE
  1. ;
  1. ; Reference/ICR
  1. ; Registration/4943
  1. ;
  1. N DIERR,SDWLDAX
  1. I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
  1. S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
  1. .S SDWLDAX="`"_SDWLDA
  1. .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)
  1. I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
  1. K SDWLOUT S SDWLOUT=$NA(^TMP("DILIST",$J))
  1. Q
  1. OUTPUT1(SDWLOUT,SDWLDFN) ;
  1. ;Brief Output - for Wait List.
  1. ; input:
  1. ; DFN = Patient
  1. ; Lookup uses Wait List data file (409.3) and returns the following data.
  1. ;
  1. ; output:
  1. ; SWDLRES = On/Not on Wait list^Number of IENs^IEN;IEN;IEN;IEN.....
  1. ; 1 0 ^ 2 ^1;2
  1. ;
  1. S SDWLCNT=0,SDWLIEN=""
  1. I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=$NA(^TMP("SDWLRP1",$J)),^TMP("SDWLRP1",$J,1)=-1
  1. S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
  1. .I $P(^SDWL(409.3,SDWLDA,0),U,17)["C" Q
  1. .S SDWLCNT=SDWLCNT+1
  1. .S ^TMP("SDWLRP1",$J,SDWLCNT)=SDWLDA_"^"_$G(^SDWL(409.3,SDWLDA,0))
  1. S SDWLOUT=$NA(^TMP("SDWLRP1",$J))
  1. K SDWLDFN,SDWLDA,SDWLCNT,SDWLIEN
  1. Q
  1. OUTPUT3(SDWLOUT,SDWLDFN) ;Disposition Data
  1. ; input:
  1. ; DFN = Patient Internal ID
  1. ;
  1. ; output: Subscript 'DIS'
  1. ; Date Dispositioned^Disposition by^Disposition
  1. ;
  1. N SDWLRES,SDWLDFN,SDWLDA,DIERR
  1. I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES=-1 Q ;- No Entry in Wait List file.
  1. S SDWLDA="" F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA<1 D
  1. .S SDWLDAX="`"_SDWLDA
  1. .D FIND^DIC(409.3,,"19;20;21","PS",.SDWLDAX)
  1. I $G(DIERR) D CLEAN^DILF S SDWLRES=-1 Q
  1. K SDWLOUT S SDWLOUT="^TMP(""DILIST"","_$J_")",SDWLRES=1
  1. Q
  1. INPUT(SDWLRES,SDWLSTR) ;
  1. ; Input:
  1. ; SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
  1. ; (R) = Required Field
  1. ; (O) = Optional
  1. ;
  1. ; .01 2 3 5 6
  1. ; 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. ; 1 2 3 4 5 6 7 8 9 10
  1. ;
  1. ; Output:
  1. ; SDWLRES = 0 Failed
  1. ; SDWLRES = 1^IEN Saved to ^SDWL(409.3,IEN,0)
  1. ;
  1. N DIERR,%H,SDWLF,SDWLFLD,SDWLFLG,SDWLI,SDWLIN,SDWLMSG,SDWLRNED,SDWLTP,SDWLVAL,SDWLX,SDWLY,X,Y
  1. K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J)
  1. I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
  1. D NEW
  1. D FDA I SDWLRES<0 D DEL Q
  1. ;D VAL I SDWLRES<0 D DEL Q
  1. D SET I SDWLRES<0 D DEL Q
  1. D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
  1. ; SD*5.3*611 stops variables SDWLDUZ,SDWLDFN,SDWLDA from being killed until END^SDWLE113
  1. K Y
  1. Q
  1. NEW ;Get IEN from ^SDWL(409.3,IEN,0).
  1. N DA,DIC,DIE,DIK,DR,SDREJ,SDINTRA,SDMULTI
  1. I $P(SDWLSTR,U,4) D
  1. .S SDWLTP=+$P(SDWLSTR,U,4)
  1. .S SDWLIN=$P($G(^SCTM(404.51,+$P(^SCTM(404.57,SDWLTP,0),U,2),0)),U,7)
  1. I $P(SDWLSTR,U,3) D
  1. .S SDWLIN=$P($G(^SCTM(404.51,+$P(SDWLSTR,U,3),0)),U,7)
  1. S SDWLDFN=+$P(SDWLSTR,U,1)
  1. S SDREJ=$P(SDWLSTR,U,9),SDINTRA=$P(SDWLSTR,U,8),SDMULTI=$P(SDWLSTR,U,10)
  1. ;identify INTRA-transfer
  1. ;- last team assignment
  1. 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
  1. S SDWLDFN=$P(Y,U,2),SDWLDA=+Y,SDWLDUZ=$P(SDWLSTR,U,9)
  1. S DIE="^SDWL(409.3,",DA=SDWLDA
  1. S DR="1///^S X=DT" D ^DIE
  1. S DR="2////^S X=SDWLIN;32////^S X=SDREJ;34////^S X=SDINTRA;38////^S X=SDMULTI" D ^DIE
  1. S DR="23///^S X=""O""",DIE="^SDWL(409.3," D ^DIE
  1. ;
  1. ;DETERMINE ENROLLEE STATUS
  1. ;
  1. ;SDWLE=1 = NEW ENROLLEE
  1. ;SDWLE=2 = ESTABLISHED
  1. ;SDWLE=3 = PRIOR ENROLLEE
  1. ;SDWLE=4 = UNDETERMINED
  1. ;
  1. S SDWLDE=+$H,SDWLE=0,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1
  1. G SB0:SDWLE=2
  1. S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3)
  1. 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
  1. I $D(SDWLDET),SDWLDET>365 S SDWLE=3
  1. I 'SDWLRNE S SDWLE=4
  1. SB0 I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
  1. .I 'SDWLRNE,SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
  1. .I 'SDWLEE S SDWLE=4 Q
  1. S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
  1. ;-Code here for filling in 409.3
  1. S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
  1. S DR="9////^S X=DUZ" D ^DIE
  1. S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
  1. S DR="27.2////^S X=SDWLDB" D ^DIE
  1. K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE
  1. Q
  1. SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDB S SDWLE=3 Q
  1. S SDWLX="" F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D
  1. .S SDWLY=$P($G(^DGCN(391.91,SDWLX,0)),U,2,3) D
  1. ..;CHECK FOR TREATING FACILITY
  1. ..I $$TF^XUAF4(+$P(SDWLY,U)) D
  1. ...;SORT FOR LAST TREATMENT DATE
  1. ...S SDWLD=$P(SDWLY,U,2) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
  1. I '$D(SDWLDTF) Q
  1. 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
  1. I $D(SDWLEE),SDWLEE>730!(SDWLEE=730) S SDWLE=3
  1. K SDWLDTF
  1. Q
  1. FDA ;Get data from SDWLSTR string and set FDA.
  1. S SDWLF=409.3
  1. S SDWLVAL="" F SDWLI=2:1:7 S SDWLVAL=$P(SDWLSTR,"^",SDWLI) D
  1. .S SDWLFLD=SDWLI D
  1. ..S SDWLFLD=$S(SDWLFLD=2:4,SDWLFLD=3:5,SDWLFLD=4:6,SDWLFLD=5:9,SDWLFLD=7:15,1:25)
  1. .S SDWLFLG="F",SDWLIEN=$$IENS^DILF(SDWLDA) ;,SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
  1. .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
  1. .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
  1. .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
  1. Q
  1. VAL ;Validate fields
  1. N DIERR
  1. D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
  1. I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
  1. M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
  1. Q
  1. SET ;Input data to file ^SDWL(409.3,IEN,0).
  1. D UPDATE^DIE(,"^TMP(""SDWLIN"",$J)","SDWLMSG")
  1. I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
  1. S SDWLRES=1_"^"_$G(SDWLDA)
  1. Q
  1. DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK
  1. S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
  1. Q
  1. INPUTDP(SDWLRES,SDWLSTR) ;Set disposition in Wait List Patient file
  1. ;
  1. ; Input:
  1. ;
  1. ; SDWLSTR=Patient DFN^Disposition^User DUZ^Wait List IEN
  1. ;
  1. ; Ouput:
  1. ;
  1. ; SDWLRES=-1 Failed
  1. ; SDWKRES=1^IEN for Wait List File (409.3)
  1. ;
  1. N SDWLDFN,SDWLDISP,SDWLDUZ,SDWLDA,SDWLDDT
  1. I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing" Q
  1. I '$G(^SDWL(409.3,SDWLDA,0)) S SDWLRES="-1^Missing Patient IEN" Q
  1. I '$D(^SDWL(409.3,"B",SDWLDFN)) S SDWLRES="-1^Missing Wait List data file" Q
  1. D FDA1 I SDWLRES<0 D DEL1 Q
  1. D VAL1 I SDWLRES<0 D DEL1 Q
  1. D SET1 I SDWLRES<0 D DEL1 Q
  1. D CLEAN^DILF K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J)
  1. Q
  1. FDA1 ;
  1. S SDWLDFN=$P(SDWLSTR,U,1),SDWLDISP=$P(SDWLSTR,U,2),SDWLDUZ=$P(SDWLSTR,U,3),SDWLDA=$P(SDWLSTR,U,4),SDWLDDT=DT
  1. S SDWLIEN=$$IENS^DILF(SDWLDA)
  1. 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
  1. .S SDWLVAL=$$EXTERNAL^DILFD(SDWLF,SDWLFLD,,SDWLVAL,"SDWLMSG")
  1. .I $D(SDWLMSG) M SDWLRES=SDWLMSG S SDWLRES=-1 Q
  1. .D FDA^DILF(SDWLF,SDWLIEN,SDWLFLD,"",SDWLVAL,"^TMP(""SDWLIN"",$J)")
  1. .S SDWLRES=1 M SDWLRES("SDWLIN")=^TMP("SDWLIN",$J)
  1. Q
  1. VAL1 ;
  1. N DIERR
  1. D VALS^DIE(,"^TMP(""SDWLIN"",$J)","^TMP(""SDWLOUT"",$J)","SDWLMSG")
  1. I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
  1. M SDWLRES("SDWLOUT")=^TMP("SDWLOUT",$J)
  1. Q
  1. SET1 ;
  1. D UPDATE^DIE(,"^TMP(""SDWLOUT"",$J)","SDWLMSG")
  1. I $G(SDWLMSG("DIERR")) S SDWLRES=-1 Q
  1. S SDWLRES=1
  1. Q
  1. DEL1 ;
  1. S DA(1)=SDWLDA,DIK="^SDWL("_DA(1)_",""DIS""," F DA=19,20,21,23 D ^DIK
  1. S SDWLRES="-1^"_"Disposition Nodes Deleted."
  1. Q