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