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

SDWLIFT6.m

Go to the documentation of this file.
  1. SDWLIFT6 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: DISPLAY ACCEPT DETAILS ;1/5/16 11:00am
  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. ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER
  1. ;
  1. Q
  1. EN ; INITIALIZE VARIABLES FOR DISPLAY
  1. N DFN,SDWLI,SDWLOK,SDWLIFN0
  1. K SDWLLIST
  1. D GETLIST^SDWLIFT5
  1. S (SDWLIFTN,SDWLIFN0)=$$GETTN^SDWLIFT(.SDWLLIST)
  1. I 'SDWLIFTN S VALMBCK="R" Q
  1. L +^SDWL(409.36,SDWLIFTN):10 I '$T S VALMBCK="R" Q
  1. ; Refresh list and loop to ensure that the selection hasn't been removed while the choice was being made.
  1. K SDWLLIST D GETLIST^SDWLIFT5
  1. S (SDWLOK,SDWLI)=0 F S SDWLI=$O(SDWLLIST(SDWLI)) Q:'SDWLI I SDWLLIST(SDWLI,1)=SDWLIFTN S SDWLOK=1 Q
  1. D:SDWLOK
  1. .N DIC,DFN,SDWLDFN,SDWLICN,SDWLSSN,SDWLTY,X,Y
  1. .S SDWLICN=$$GET1^DIQ(409.36,SDWLIFTN,991.01)
  1. .S SDWLSSN=$$GET1^DIQ(409.36,SDWLIFTN,.09)
  1. .S (DFN,SDWLDFN)=$S(+SDWLICN:$O(^DPT("AICN",SDWLICN,"")),1:"")
  1. .I DFN="" S (DFN,SDWLDFN)=$S(+SDWLSSN:$O(^DPT("SSN",SDWLSSN,"")),1:"")
  1. .S SDWLTY=$$GET1^DIQ(409.36,SDWLIFTN,4,"I")
  1. .D EN^VALM("SDWL TRANSFER ACC VIEW")
  1. .Q
  1. L -^SDWL(409.36,SDWLIFN0)
  1. D INIT^SDWLIFT5
  1. S VALMBCK="R"
  1. Q
  1. INIT ; Default initialization options.
  1. N SDWLINFO
  1. D GETINFO(.SDWLINFO)
  1. F VALMCNT=1:1:SDWLINFO(0) D SET^VALM10(VALMCNT,SDWLINFO(VALMCNT,0))
  1. Q
  1. GETINFO(SDWLOUT) ; The Coversheet function calls here too.
  1. N DIC,D,X,WP,TMP,SDWLADD,SDWLFID,SDWLI
  1. D GETS^DIQ(409.36,SDWLIFTN,"*",,"TMP")
  1. S SDWLOUT(0)=1
  1. D:SDWLDFN=""
  1. .S SDWLOUT(SDWLOUT(0),0)="Patient not registered"
  1. .S SDWLOUT(0)=SDWLOUT(0)+1
  1. .D CNTRL^VALM10(1,1,22,IOINHI,IOINORM)
  1. .Q
  1. S SDWLOUT(SDWLOUT(0),0)="Transmg. Inst: "_$E($$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.36,SDWLIFTN_",",.1),"D"),.01)_SDWLSPS,1,28)_" "
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Transmn. Date: "_TMP(409.36,SDWLIFTN_",",.2)
  1. S SDWLOUT(0)=SDWLOUT(0)+1
  1. S SDWLOUT(SDWLOUT(0),0)="Name: "_$E(TMP(409.36,SDWLIFTN_",",.01)_SDWLSPS,1,27)_" "
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"Sex: "_$E(TMP(409.36,SDWLIFTN_",",.02)_SDWLSPS,1,7)
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"DoB: "_$E(TMP(409.36,SDWLIFTN_",",.03)_SDWLSPS,1,13)
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_"SSN: "_TMP(409.36,SDWLIFTN_",",.09)
  1. ;
  1. S SDWLOUT(0)=SDWLOUT(0)+1,SDWLADD=SDWLOUT(0)
  1. S SDWLOUT(SDWLOUT(0),0)=$E("Address: "_TMP(409.36,SDWLIFTN_",",.111)_SDWLSPS,1,58)_" Status: "_TMP(409.36,SDWLIFTN_",",1)
  1. F SDWLFID=.112:.001:.114,.117 I TMP(409.36,SDWLIFTN_",",SDWLFID)'="" S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)=$E(SDWLSPS,1,9)_TMP(409.36,SDWLIFTN_",",SDWLFID)
  1. I TMP(409.36,SDWLIFTN_",",.115)_TMP(409.36,SDWLIFTN_",",.116)'="" D
  1. .S SDWLOUT(0)=SDWLOUT(0)+1
  1. .S SDWLOUT(SDWLOUT(0),0)=$E(SDWLSPS,1,9)
  1. .I TMP(409.36,SDWLIFTN_",",.115)'="" S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",.115)
  1. .S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" "_TMP(409.36,SDWLIFTN_",",.116)
  1. .Q
  1. I TMP(409.36,SDWLIFTN_",",.131)'="" S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Phone no "_TMP(409.36,SDWLIFTN_",",.131)
  1. D:TMP(409.36,SDWLIFTN_",",.1217)'="" ; Temporary address details. Displayed to the right of the address in up to 3 lines starting column 62
  1. .S SDWLOUT(SDWLADD,0)=$E(SDWLOUT(SDWLADD,0)_SDWLSPS,1,61)_"Temporary address" ; There should be at least three lines if it is also indicated as temporary.
  1. .S SDWLOUT(SDWLADD+1,0)=$E(SDWLOUT(SDWLADD+1,0)_SDWLSPS,1,61)_"From: "_TMP(409.36,SDWLIFTN_",",.1217)
  1. .S SDWLOUT(SDWLADD+2,0)=$E(SDWLOUT(SDWLADD+2,0)_SDWLSPS,1,61)_"To : "_TMP(409.36,SDWLIFTN_",",.1218)
  1. .Q
  1. S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Service connected: "_TMP(409.36,SDWLIFTN_",",.301)
  1. I TMP(409.36,SDWLIFTN_",",.301)="YES" S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Percentage: "_TMP(409.36,SDWLIFTN_",",.302)
  1. S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Primary Eligibility: "_TMP(409.36,SDWLIFTN_",",.361)
  1. S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Wait List Type: "
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",4)_" : "_TMP(409.36,SDWLIFTN_",",5)
  1. ; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
  1. ;S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Desired Date of Appt: "
  1. S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="CID/Preferred Date of Appt: "
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",22)
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_" Integration Control Number: "
  1. S SDWLOUT(SDWLOUT(0),0)=SDWLOUT(SDWLOUT(0),0)_TMP(409.36,SDWLIFTN_",",991.01)
  1. S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)="Comments: "
  1. S X=$$GET1^DIQ(409.36,SDWLIFTN_",",.4,"Z","WP")
  1. S SDWLI=0 F S SDWLI=$O(WP(SDWLI)) Q:'SDWLI S SDWLOUT(0)=SDWLOUT(0)+1,SDWLOUT(SDWLOUT(0),0)=WP(SDWLI,0)
  1. Q
  1. GETTN(SDWLLIST) ; Get transfer id.
  1. N DIR,Y
  1. I 'SDWLLIST(0) S DIR(0)="Y",DIR("A")="No entries. OK",DIR("B")="YES" D ^DIR Q 0
  1. I SDWLLIST(0)=1 S Y=1 ; If there is only one, don't ask.
  1. E S DIR(0)="L^1:"_SDWLLIST(0),DIR("A")="Which entry?" D ^DIR
  1. Q $G(SDWLLIST(+Y,1),0)
  1. HD ; -- Make header line for list processor
  1. S (VALMHDR(1),VALMHDR(2))=""
  1. Q
  1. PCMM(SDWLIFTN,DFN) ;
  1. N SDWLPCMM,SDWLRES,DIE,DA,DR
  1. I $G(DFN)="" W !,"Patient not entered on the system. Use Load/edit" S DIR(0)="E",VALMBCK="R" D ^DIR Q
  1. S (SDWLPCMM,SDWLRES)=0
  1. D PAT^SCMCQK
  1. ;If a PCMM assignment was made, close 409.36
  1. ;if an EWL Entry was created instead, add pointer
  1. ;then pass a message back.
  1. Q:'SDWLPCMM&'SDWLRES
  1. S DIE="^SDWL(409.36,",DA=SDWLIFTN
  1. I SDWLPCMM S DR="1///C"
  1. E S DR="409.3///"_$P(SDWLRES,U,2)
  1. D ^DIE,SENDST(SDWLIFTN)
  1. Q
  1. ;
  1. ACCEPT ; Sign the transaction off as accepted. Remove the temporary file and send a message to transmitting facility
  1. N DIR
  1. I $$GET1^DIQ(409.36,SDWLIFTN,.3)'="YES" D Q
  1. .S DIR("A")="A coversheet does not appear to have been requested."_$C(13,10)_"This is required before acceptance. Enter RETURN to continue or '^' to exit"
  1. .S DIR(0)="E"
  1. .D ^DIR
  1. .S VALMBCK=$S(Y:"R",1:"Q")
  1. .Q
  1. D FULL^VALM1
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you confirm that the appropriate action was taken to schedule this patient"_$C(13,10)_"for an appointment or she/he has EWL entry and the cover sheet has been printed"
  1. S DIR("B")="N"
  1. D ^DIR
  1. D:Y
  1. .N SDWLSTN,SDWLINST,XMY,XMSUB,XMTEXT,XMDUZ,SDWLX,DA,DIK
  1. .S SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
  1. .S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
  1. .S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
  1. .S XMSUB="SDWL TRANSFER ACCEPTANCE"
  1. .S XMTEXT="SDWLX("
  1. .S XMDUZ="POSTMASTER"
  1. .S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
  1. .S SDWLX(2,0)="7"_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
  1. .S SDWLX(0)=2
  1. .D ^XMD
  1. .S DA=SDWLIFTN,DIK="^SDWL(409.36," D ^DIK
  1. .Q
  1. S VALMBCK="Q"
  1. Q
  1. REJECT ; Sign the transaction off as rejected. Remove the temporary file and send a message to transmitting facility
  1. N SDWLSTN,SDWLINST,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX
  1. S SDWLSTN=$$GET1^DIQ(409.36,SDWLIFTN,.1)
  1. S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
  1. S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
  1. S XMSUB="SDWL TRANSFER REJECTION"
  1. S XMTEXT="SDWLX("
  1. S XMDUZ="POSTMASTER"
  1. S SDWLX(1,0)=".5"_U_"SENDING FACILITY TRANSFER ID"_U_$$GET1^DIQ(409.36,SDWLIFTN,.5)
  1. S SDWLX(0)=1
  1. D ^XMD
  1. S DA=SDWLIFTN,DIK="^SDWL(409.36," D ^DIK
  1. ;teh/05/20/2005 cleans the SDWLLIST array and reset count.
  1. K SDWLLIST(SDWLIFTN)
  1. S SDWLLIST(0)=SDWLLIST(0)-1
  1. S VALMBCK="Q"
  1. EXIT ; Tidy up
  1. K SDWLIFTN
  1. Q
  1. SENDST(SDWLIFTN) ; Send status change notification
  1. N SDWLSTN,SDWLINST,TMP,XMSUB,XMY,XMTEXT,XMDUZ,SDWLX,SDWLDA,SDWLDIS
  1. S SDWLDA=$$GET1^DIQ(409.36,SDWLIFTN,409.3,"I"),SDWLDIS=$$GET1^DIQ(409.3,SDWLDA,21,"I")
  1. D GETS^DIQ(409.36,SDWLIFTN,".1;.5;1;2","I","TMP")
  1. S SDWLSTN=TMP(409.36,SDWLIFTN_",",.1,"I")
  1. S SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
  1. S XMY("S.SDWL-XFER-SERVER@"_$$GET1^DIQ(4,SDWLINST,60))=""
  1. S XMSUB="SDWL TRANSFER STATUS CHANGE"
  1. S XMTEXT="SDWLX("
  1. S XMDUZ="POSTMASTER"
  1. S SDWLX(1,0)=.5_U_"SENDING FACILITY TRANSFER ID"_U_TMP(409.36,SDWLIFTN_",",.5,"I")
  1. S SDWLX(2,0)=1_U_"STATUS"_U_TMP(409.36,SDWLIFTN_",",1,"I")
  1. S SDWLX(3,0)=7_U_"ACCEPTING PERSON"_U_$$GET1^DIQ(200,DUZ,.01)
  1. S SDWLX(4,0)=2_U_"FACILITY TRANFERRED TO"_U_TMP(409.36,SDWLIFTN_",",2,"I")
  1. S SDWLX(5,0)=21_U_"DISPOSITION"_U_SDWLDIS
  1. S SDWLX(0)=5
  1. D ^XMD
  1. Q