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.
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