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

SDWLRP4.m

Go to the documentation of this file. 
  1. SDWLRP4 ;IOFO BAY PINES/TEH - WAITING LIST - MERGE RPC;06/28/2002 ; 26 Aug 2002  1:25 PM
  1.  ;;5.3;scheduling;**263,485,497,1015**;AUG 13 1993;Build 21
  1.  ;
  1. INPUT(SDWLRES,SDWLSTR) ;
  1.  ;
  1.  ;     
  1.  ; Input:
  1.  ;   SDWLSTR = location of data = ^TMP("SDWLG",$J,i,0)
  1.  ;   (R) = Required Field
  1.  ;   (O) = Optional
  1.  ;   
  1.  ;   .01                2             3        4          5           9               10        11           23       22
  1.  ;  SSN (R)^ORIGINATING DATE^INSTITUTION^TYPE (R)^^TYPE MOD^ORGINATING USER (R)^PRIORITY^REQUEST BY^CURRENT STATUS^DESIRED DATE
  1.  ;    1              2                3        4        6/7/8/9       10               11       12              17    16   
  1.  ;
  1.  ;  Output:
  1.  ;               SDWLRES  =  -1^MESSAGE      Failed
  1.  ;               SDWLRES  =  1^IEN  Saved to ^SDWL(409.3,IEN,0)            
  1.  ;
  1.  ;
  1.  K ^TMP("SDWLIN",$J),^TMP("SDWLOUT",$J),^TMP("DIERR",$J),D
  1.  I '$G(SDWLSTR) S SDWLRES="-1^Data String Missing^Failed" Q
  1.  I $P(SDWLSTR,U)="" S SDWLRES="-1^No SSN^Failed" Q
  1.  I $P(SDWLSTR,U,3)="" S SDWLRES="-1^No Insitution^Failed" Q
  1.  I $P(SDWLSTR,U,4)="" S SDWLRES="-1^No Type^Failed" Q
  1.  I $P(SDWLSTR,U,6)="",$P(SDWLSTR,U,7)="",$P(SDWLSTR,U,8)="",$P(SDWLSTR,U,9)="" S SDWLRES="-1^No Type Modifier^Failed" Q
  1.  I $P(SDWLSTR,U,11)'="",$$DCHK($P(SDWLSTR,U,11))<1 S SDWLRES="-1^Invalid Date^Failed" Q
  1.  S $P(SDWLSTR,U)=$TR($P(SDWLSTR,U),"-","")
  1.  D NEW
  1.  I $P(SDWLRES,U,1)<0 Q
  1.  D FDA 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.  Q
  1. NEW ;Get IEN from ^SDWL(409.3,IEN,0).
  1.  N SDWLTP,SDWL6,SDWL6P,SDWL7,SDWL7P,SDWL8,SDWL8P,SDWL9,SDWL9P,SDWLMOD,SDWLTP,SDWLIN,SDWLDFN
  1.  N SDWLPRI,SDWLODUZ,SDWLRBY
  1.  S SDWLRES=""
  1.  I $P(SDWLSTR,U,4) D
  1.  .S SDWLTP=+$P(SDWLSTR,U,4),(SDWL6,SDWL7,SDWL8,SDWL9)="",SDWLMOD=0 D
  1.  ..I SDWLTP=1 S SDWL6=$P(SDWLSTR,U,6),SDWL6=$O(^SCTM(404.51,"B",SDWL6,"")) I SDWL6'="" S SDWL6P=$O(^SCTM(404.51,"B",SDWL6,0)),SDWLMOD=1
  1.  ..I SDWLTP=2 S SDWL7=$P(SDWLSTR,U,7),SDWL7=$O(^SCTM(404.57,"B",SDWL7,"")) I SDWL7'="" S SDWL7P=$O(^SCTM(404.57,"B",SDWL7,0)),SDWLMOD=1
  1.  ..I SDWLTP=3 S SDWL8=$P(SDWLSTR,U,8),SDWL80="" F  S SDWL80=$O(^DIC(40.7,"B",SDWL8,SDWL80))  Q:SDWL80=""  D
  1.  ...I $D(^SDWL(409.31,"B",SDWL80)) S SDWL8=$O(^SDWL(409.31,"B",SDWL80,0)),$P(SDWLSTR,U,8)=SDWL8,SDWLMOD=1
  1.  ..I SDWLTP=4 S SDWL9=$P(SDWLSTR,U,9),SDWL90="" F SDWL90=$O(^SC("B",SDWL9,SDWL90)) Q:SDWL90=""  D
  1.  ...I $D(^SDWL(409.32,"B",SDWL90)) S SDWL9=$O(^SDWL(409.32,"B",SDWL90,0)),$P(SDWLSTR,U,9)=SDWL9,SDWLMOD=1
  1.  I 'SDWLMOD S SDWLRES="-1^No Type Mod found^Failed" Q
  1.  S SDWLIN=$P(SDWLSTR,U,3) I SDWLIN="" S SDWLRES="-1^No Institution^Failed" Q
  1.  S SDWLIN=$O(^DIC(4,"B",SDWLIN,0)) I SDWLIN="" S SDWLRES="-1^Invalid Institution^Failed" Q
  1.  S SDWLDFN=$P(SDWLSTR,U,1) S D="SSN",DIC(0)="MNZ",X=SDWLDFN,D="SSN",DIC=2 D IX^DIC I Y<0 S SDWLRES="-1^SSN failed" Q
  1.  S SDWLDFN=+Y
  1.  I SDWLDFN="" S SDWLRES="-1^Invalid SSN^Failed" Q
  1.  I $$DUP(SDWLDFN) S SDWLRES="-1^Duplicate^Failed" Q
  1.  S SDWLPRI=$S($P(SDWLSTR,U,11)="":"A",1:"F")
  1.  S SDWLODUZ=.5,SDWLRBY=2
  1.  I SDWLTP=1!(SDWLTP=2) S SDWLPRI="A",SDWLRBY=""
  1.  S SDWLSTRN=SDWLTP_"^"_SDWLPRI_"^"_SDWLODUZ_"^"_SDWLRBY_"^"_SDWL6_"^"_SDWL7_"^"_SDWL8_"^"_SDWL9
  1.  S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN I Y<0 S SDWLRES="-1^IEN failed^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.  I SDWLPRI="F" D
  1.  .S DR="22///"_$P(SDWLSTR,U,11) D ^DIE
  1.  I SDWLPRI="A",SDWLTP=3!(SDWLTP=4) D
  1.  .S DR="22///^S X=DT" D ^DIE
  1.  S DR="1////^S X=DT" D ^DIE
  1.  S DR="2////^S X=SDWLIN" D ^DIE
  1.  S DR="23////^S X=""O""",DIE="^SDWL(409.3," D ^DIE K DIE,DR,DA
  1.  ;
  1.  ;SET DATE OF DEATH
  1.  ;
  1.  S X=$$GET1^DIQ(2,SDWLDFN_",",".351") I X'="" D
  1.  .S DA=SDWLDA
  1.  .S DR="19////^S X=DT",DIE="^SDWL(409.3," D ^DIE
  1.  .S DR="20////^S X=DUZ" D ^DIE
  1.  .S DR="23////^S X=""C""" D ^DIE
  1.  .S DR="21////^S X=""D""" D ^DIE K DIE,DR,DA
  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 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 'SDWLEE.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="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.  S DR="9////^S X=DUZ" D ^DIE K DIE,DA,DR,%H
  1.  K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE,SDWLRNED
  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=$G(^DGCN(391.91,SDWLX,0)) D
  1.  ..;CHECK FOR TREATING FACILITY
  1.  ..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
  1.  ...;SORT FOR LAST TREATMENT DATE
  1.  ...S SDWLD=$P(SDWLY,U,3) 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 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=1,2,3,4,5,6,7,8 S SDWLVAL=$P(SDWLSTRN,"^",SDWLI) D
  1.  .S SDWLFLD=SDWLI D
  1.  ..S SDWLFLD=$S(SDWLFLD=1:4,SDWLFLD=2:10,SDWLFLD=3:9,SDWLFLD=4:11,SDWLFLD=5:5,SDWLFLD=6:6,SDWLFLD=7:7,SDWLFLD=8:8)
  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.  ;
  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.  ;
  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.  K DIC,DA
  1.  S SDWLRES=1_"^"_$G(SDWLDA)
  1.  Q
  1. DEL S DA=SDWLDA,DIK="^SDWL(409.3," D ^DIK K DIK,DA
  1.  S SDWLRES="-1^Entry "_SDWLDA_" Deleted"
  1.  Q
  1. DUP(IEN) ;Duplicate Check
  1.  ;if institution, wait list type, and wait list modifier are the same it's a duplicate
  1.  ;SDWLV1  :  IEN in 409.3
  1.  ;SDWLV2  :  Zero node of 409.3
  1.  ;SDWLV3  :  Wait List Type Modifier value passed in
  1.  ;SDWLV4  :  Wait List Type Modifier value in current record
  1.  ;SDWLIN  :  Institution value passed in checked against piece 3 of current record
  1.  ;SDWLSTR :  Incoming value string
  1.  ;           Wait List Type piece 4 of SDWLSTR (incoming value) checked against piece 5
  1.  ;           of SDWLV2 (zero node of current record
  1.  N SDWLV1,SDWLV2,SDWLV3,SDWLV4,SDWLV5
  1.  S (SDWLV1,SDWLV5)=0
  1.  F  S SDWLV1=$O(^SDWL(409.3,"B",IEN,SDWLV1)) Q:('SDWLV1!SDWLV5)  D
  1.  . S SDWLV2=$G(^SDWL(409.3,SDWLV1,0)) Q:SDWLV2=""
  1.  . S SDWLV3=$S($P(SDWLSTR,U,4)=1:SDWL6,$P(SDWLSTR,U,4)=2:SDWL7,$P(SDWLSTR,U,4)=3:SDWL8,$P(SDWLSTR,U,4)=4:SDWL9,1:0)
  1.  . S SDWLV4=$S($P(SDWLV2,U,5)=1:$P(SDWLV2,U,6),$P(SDWLV2,U,5)=2:$P(SDWLV2,U,7),$P(SDWLV2,U,5)=3:$P(SDWLV2,U,8),$P(SDWLV2,U,5)=4:$P(SDWLV2,U,9),1:0)
  1.  . I $P(SDWLV2,U,3)=SDWLIN,$P(SDWLSTR,U,4)=$P(SDWLV2,U,5),SDWLV3=SDWLV4 S SDWLV5=1 Q
  1.  Q SDWLV5
  1. DCHK(VALID) ;Check for valid DESIRED DATE
  1.  N X
  1.  S X=VALID,%DT="X" D ^%DT
  1.  Q Y