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