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

SDWLIFT3.m

Go to the documentation of this file. 
  1. SDWLIFT3 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: NEW TRANSFER ;1/5/16 10:59am
  1.  ;;5.3;Scheduling;**415,446,645**;AUG 13 1993;Build 7
  1.  ;
  1.  ;
  1.  ;******************************************************************
  1.  ;                             CHANGE LOG
  1.  ;                                               
  1.  ;   DATE                        PATCH                   DESCRIPTION
  1.  ;   ----                        -----                   -----------
  1.  ;   12/12/05                    SD*5.3*446              Enhancements
  1.  ;
  1.  Q
  1. EN ; INITIALIZE VARIABLES
  1.  N DIR,DIC,DR,DIE,VADM,X,Y
  1.  D FULL^VALM1
  1.  D EN2()
  1.  D INIT^SDWLIFT1(0)
  1.  ; VALMBCK required by List Manager
  1.  S VALMBCK="R"
  1.  Q
  1. EN2(SDWLDA) ; Entry point if Wait List has been selected elsewhere.
  1.  ; SDWLOPT is the option to be queried.
  1.  ; 1: Patient & Wait List Entry
  1.  ; 2: Institution
  1.  ; 3: Comments
  1.  ; 4: Processing
  1.  ; 5: Confirmation
  1.  N SDWLOPT,SDWLOPT0
  1.  S SDWLOPT=2
  1.  I '$D(SDWLDA) S SDWLDA="",SDWLOPT=1
  1.  S SDWLOPT0=SDWLOPT
  1.  F  D  Q:'SDWLOPT
  1.  .N SDWLDFN,SDWLDMN,SDWLIFTN,SDWLINST,DIC,DIE,DIR,DA,DO,I,Y,%,DIWETXT
  1.  .I SDWLOPT=1 D
  1.  ..N DFN,SDWLOK,SDWLOUT,SDWLC,SDWLI,SDWLNM,SDWLTMP
  1.  ..K Y,X
  1.  ..S DIC=2,DIC(0)="AEMZ",DIC("S")="I $$ISEWL^SDWLIFT3(+Y)"
  1.  ..D ^DIC
  1.  ..I Y=-1 S SDWLOPT=0 Q
  1.  ..S DFN=+Y  ; DFN used to uniquely identify the patient in the following look-up.
  1.  ..D LIST^DIC(409.3,,".01;2;4;5;6;7;8",,,,$P(Y,U,2),,"I $$ISEWL2^SDWLIFT3(Y,DFN)",,"SDWLTMP")
  1.  ..F I=1:1:+SDWLTMP("DILIST",0) D
  1.  ...N TMP,SDWLSTA
  1.  ...S TMP=""
  1.  ...I SDWLTMP("DILIST","ID",I,2)'="" S TMP=TMP_SDWLTMP("DILIST","ID",I,2)_"  "
  1.  ...D:SDWLTMP("DILIST","ID",I,4)'=""
  1.  ....S SDWLTMP("WLTY",I,0)=SDWLTMP("DILIST","ID",I,4),SDWLSTA=$$GET1^DIQ(409.3,SDWLTMP("DILIST",2,I),4,"I")
  1.  ....I SDWLTMP("DILIST","ID",I,SDWLSTA+4)'="" S SDWLTMP("WLTY",I,0)=SDWLTMP("WLTY",I,0)_" ("_SDWLTMP("DILIST","ID",I,SDWLSTA+4)_")"
  1.  ....S TMP=TMP_SDWLTMP("WLTY",I,0)
  1.  ....Q
  1.  ...S $P(DIR(0),";",I)=I_":"_TMP
  1.  ...Q
  1.  ..; If there is only one EWL entry, use that. The previous look-up will have ensured there is at least one.
  1.  ..; If there are more than one, call ^DIR to select.
  1.  ..S Y=1
  1.  ..I +SDWLTMP("DILIST",0)>1 S DIR(0)="S^"_DIR(0),DIR("A")="Enter 1 - "_+SDWLTMP("DILIST",0) D ^DIR  Q:Y="^"
  1.  ..W !?4,"Institution:",?20,SDWLTMP("DILIST","ID",Y,2)
  1.  ..W !?4,"Wait List Type:",?20,$G(SDWLTMP("WLTY",Y,0))
  1.  ..S SDWLDA=SDWLTMP("DILIST",2,Y)
  1.  ..I $D(^SDWL(409.36,"C",SDWLDA)) S SDWLOK=0 D  I SDWLOK S SDWLOPT=0 Q
  1.  ...N SDWLIFTN,SDWLSTN
  1.  ...S SDWLIFTN=$O(^SDWL(409.36,"C",SDWLDA,"")),SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,".1")
  1.  ...S DIR(0)="E",DIR("A")="Press return to continue"
  1.  ...S DIR("A",1)="This EWL Entry is the result of a transfer request from "_$$GET1^DIQ(4,SDWLSTN,".01")_" ("_SDWLSTN_")"
  1.  ...;S DIR("A",2)="On acceptance at the destination facility, this EWL Entry will be removed."
  1.  ...S DIR("A",2)="To transfer care, close the EWL Entry as ER - ENTERED IN ERROR and reject the"
  1.  ...S DIR("A",3)="request. "_$$GET1^DIQ(4,SDWLSTN,".01")_" can then request the transfer."
  1.  ...D ^DIR
  1.  ...S SDWLOK=1
  1.  ...Q
  1.  ..S SDWLOPT=2
  1.  ..Q
  1.  .D:SDWLOPT=2
  1.  ..N SDWLY
  1.  ..S SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
  1.  ..S DIC=4
  1.  ..S DIC(0)="EMNQA"
  1.  ..S DIC("A")="Select Institution to transfer to: "
  1.  ..S DIC("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",'+$P($G(^DIC(4,+Y,99)),U,4),$L($P($G(^DIC(4,+Y,99)),U))=3,$$GET1^DIQ(4,Y,13)=""VAMC"""
  1.  ..D ^DIC
  1.  ..I Y=-1 S SDWLOPT=$S(SDWLOPT0=2:0,1:1) Q  ; If the call was made to go straight to Institution, quit out if no institution is selected.
  1.  ..S SDWLY=+Y,SDWLDMN=$$GET1^DIQ(4,SDWLY,60)
  1.  ..I SDWLDMN=""  W !,"This Institution does not have a Domain to which the request can be sent." Q
  1.  ..S SDWLINST=SDWLY,SDWLOPT=3
  1.  ..Q
  1.  .D:SDWLOPT=3
  1.  ..S DIC="^TMP(""SDWLIFT"",$J,""COMMENT""",DIWETXT="Transfer comments"
  1.  ..W !,DIWETXT
  1.  ..K @(DIC_")") S DIC=DIC_","
  1.  ..D EN^DIWE
  1.  ..S SDWLOPT=4
  1.  ..Q
  1.  .D:SDWLOPT=4
  1.  ..N SDWLDTM
  1.  ..K DIC
  1.  ..S DIR(0)="Y",DIR("A")="OK to send",DIR("B")="YES" D ^DIR
  1.  ..I 'Y S SDWLOPT=0 Q
  1.  ..S DIC=409.35,DIC(0)="Z",X=SDWLDA
  1.  ..D FILE^DICN
  1.  ..S SDWLIFTN=+Y
  1.  ..S DA(1)=+Y,DIC=DIC_DA(1)_",1,",SDWLI=0
  1.  ..F  S SDWLI=$O(^TMP("SDWLIFT",$J,"COMMENT",SDWLI)) Q:'SDWLI  S X=^TMP("SDWLIFT",$J,"COMMENT",SDWLI,0) K DO D FILE^DICN
  1.  ..D NOW^%DTC S SDWLDTM=%
  1.  ..S DIE=409.35,DR="1///"_$$GET1^DIQ(4,SDWLINST,99)_";2///"_SDWLDTM_";3///P;4///`"_DUZ
  1.  ..D ^DIE
  1.  ..D MSG
  1.  ..S SDWLOPT=0 K DIR
  1.  ..;S DIR(0)="E" D ^DIR
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. ISEWL(DFN) ; Filter for seach of PATIENT file ; OG ; SD*5.3*446
  1.  N SDWLOK,SDWLDA
  1.  S SDWLOK=0
  1.  Q:'$D(^SDWL(409.3,"B",DFN)) SDWLOK
  1.  S SDWLDA=0
  1.  F  S SDWLDA=$O(^SDWL(409.3,"B",DFN,SDWLDA)) Q:'SDWLDA  I $$ISEWL2(SDWLDA,DFN) S SDWLOK=1 Q
  1.  Q SDWLOK
  1.  ;
  1. ISEWL2(SDWLDA,DFN) ; If the EWL entry exists, is not closed, is a team or team position assignment and not already in transit.
  1.  N TMP
  1.  ;Q $$GET1^DIQ(409.3,SDWLDA,23,"I")'="C"&'$$GETTRN^SDWLIFT1(SDWLDA)&($$GET1^DIQ(409.3,SDWLDA,.01,"I")=DFN) old way of doing it.
  1.  D GETS^DIQ(409.3,SDWLDA_",",".01;4;23","I","TMP")
  1.  Q:$G(TMP(409.3,SDWLDA_",",.01,"I"))'=DFN 0
  1.  Q TMP(409.3,SDWLDA_",",23,"I")'="C"&("^1^2^"[("^"_TMP(409.3,SDWLDA_",",4,"I")_"^"))&'$$GETTRN^SDWLIFT1(SDWLDA)
  1.  ;
  1. MSG ;acknowledgement notification to destination
  1.  N SDWLDA,SDWLDTM,DFN,TMP,SDWLTY,SDWLX,SDWLI,DIE,DA,DR,VAPA,WP
  1.  N XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLI
  1.  S XMSUB="SDWL TRANSFER REQUEST"
  1.  S XMY("S.SDWL-XFER-SERVER@"_SDWLDMN)=""
  1.  S XMTEXT="SDWLX("
  1.  S XMDUZ="POSTMASTER"
  1.  D NOW^%DTC S SDWLDTM=%
  1.  S SDWLDA=$$GET1^DIQ(409.35,SDWLIFTN,.01,"I")
  1.  D GETS^DIQ(409.3,SDWLDA,".01;4;22","I","TMP")
  1.  S DFN=TMP(409.3,SDWLDA_",",.01,"I")
  1.  S SDWLTY=TMP(409.3,SDWLDA_",",4,"I")
  1.  D DEM^VADPT,ADD^VADPT
  1.  D GETS^DIQ(2,DFN,".301;.302;991.01","I","TMP")
  1.  S SDWLX(0)=0
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".01"_U_"NAME"_U_VADM(1)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".02"_U_"SEX"_U_$P(VADM(5),U)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".03"_U_"DATE OF BIRTH"_U_$P(VADM(3),U)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".09"_U_"SOCIAL SECURITY NUMBER"_U_$P(VADM(2),U)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1"_U_"REQUESTING STATION NUMBER"_U_$P($$SITE^VASITE(),U,3)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".111"_U_"STREET ADDRESS [LINE 1]"_U_VAPA(1)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".112"_U_"STREET ADDRESS [LINE 2]"_U_VAPA(2)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".113"_U_"STREET ADDRESS [LINE 3]"_U_VAPA(3)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".114"_U_"CITY"_U_VAPA(4)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".115"_U_"STATE"_U_VAPA(5)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".116"_U_"ZIP CODE"_U_VAPA(6)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".117"_U_"COUNTY"_U_$P(VAPA(7),U)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1217"_U_"TEMPORARY ADDRESS START DATE"_U_$P(VAPA(9),U)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".1218"_U_"TEMPORARY ADDRESS END DATE"_U_$P(VAPA(10),U)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".131"_U_"PHONE NUMBER [RESIDENCE]"_U_VAPA(8)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".301"_U_"SERVICE CONNECTED?"_U_TMP(2,DFN_",",.301,"I")
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".302"_U_"SERVICE CONNECTED PERCENTAGE"_U_TMP(2,DFN_",",.302,"I")
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".361"_U_"PRIMARY ELIGIBILITY CODE"_U_$$GET1^DIQ(2,DFN,.361)
  1.  S X=$$GET1^DIQ(409.35,SDWLIFTN_",",5,"Z","WP")
  1.  S SDWLI=0 F  S SDWLI=$O(WP(SDWLI)) Q:'SDWLI  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".4"_U_"COMMENTS"_U_WP(SDWLI,0)
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=".5"_U_"SENDING FACILITY TRANSFER ID"_U_SDWLIFTN
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=2_U_"TRANSMISSION DATE/TIME"_U_SDWLDTM
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=4_U_"WAIT LIST TYPE"_U_SDWLTY
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=5_U_"WAIT LIST TYPE EXTENSION"_U_$$GET1^DIQ(409.3,SDWLDA,4+SDWLTY)
  1.  ; SD*5.3*645 - replaced DESIRED DATE with CID/PREFERRED DATE
  1.  ;S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=22_U_"DESIRED DATE OF APPOINTMENT"_U_TMP(409.3,SDWLDA_",",22,"I")
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))=22_U_"CID/PREFERRED DATE OF APPOINTMENT"_U_TMP(409.3,SDWLDA_",",22,"I")
  1.  S SDWLX(0)=SDWLX(0)+1,SDWLX(SDWLX(0))="991.01"_U_"INTEGRATION CONTROL NUMBER"_U_TMP(2,DFN_",",991.01,"I")
  1.  D ^XMD
  1.  ; Change status of transfer file to TRANSMITTED
  1.  S DIE=409.35,DA=SDWLIFTN,DR="3///T" D ^DIE
  1.  ; Update the EWL Disposition code
  1.  S DIE=409.3,DA=SDWLDA,DR="21///TR" D ^DIE
  1.  Q