SDWLIFT1 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REQUEST SUMMARY ; Compiled March 29, 2005 15:36:25
;;5.3;Scheduling;**415,1015**;AUG 13 1993;Build 21
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
;
;
Q
EN ; INITIALIZE VARIABLES
K ^TMP("SDWLIFT",$J)
K DIR,DIC,DR,DIE,VADM
S SDWLFMT=0
D EN^VALM("SDWL TRANSFER REQ MAIN")
Q
ENI ; INITIALIZE VARIABLES - Inactive entries
N SDWLFMT
K ^TMP("SDWLIFT",$J,"EP")
K DIR,DIC,DR,DIE,VADM
S SDWLFMT=2
D EN^VALM("SDWL TRANSFER REQ INAC"),INIT(0)
S VALMBCK="R"
Q
INIT(SDWLOPT) ; Default initialization options.
K ^TMP("DILIST",$J),^TMP("SDWLIFT",$J)
N SDWLINFO,SDWLI,DISPCNT
I '$D(DUZ) W !,"DUZ required for this option" D PAUSE^VALM1 Q
S SDWLDZN=$P(^VA(200,DUZ,0),U)
S SDWLSPS=$J("",30)
D GETDATA^SDWLIFT5(.SDWLINFO,SDWLOPT)
S VALMCNT=0
F DISPCNT=1:1:SDWLINFO(0) D
.N SDWLOUT
.S VALMCNT=VALMCNT+1
.; Display count
.S SDWLOUT=$E(DISPCNT_SDWLSPS,1,3)
.; Name
.S SDWLOUT=SDWLOUT_$E($P(SDWLINFO(DISPCNT,0),U)_SDWLSPS,1,27)_" "
.; SSN
.S SDWLOUT=SDWLOUT_$E($P(SDWLINFO(DISPCNT,0),U,2)_SDWLSPS,1,12)_" "
.; Destination Institution
.S SDWLOUT=SDWLOUT_$E($P(SDWLINFO(DISPCNT,0),U,3)_SDWLSPS,1,20)_" "
.; Transfer Status
.S SDWLOUT=SDWLOUT_$P(SDWLINFO(DISPCNT,0),U,4)
.D SET^VALM10(VALMCNT,SDWLOUT)
.; Line 2
.S VALMCNT=VALMCNT+1
.; Current Wait List Institution
.S SDWLOUT=$E($P(SDWLINFO(DISPCNT,0),U,5)_SDWLSPS,1,30)_" "
.; Current Wait List Type
.S SDWLOUT=SDWLOUT_$P(SDWLINFO(DISPCNT,0),U,6)_" : "
.; Current Wait List Type Extension
.S SDWLOUT=SDWLOUT_$P(SDWLINFO(DISPCNT,0),U,7)
.D SET^VALM10(VALMCNT,SDWLOUT)
.Q
I 'VALMCNT S VALMCNT=1 D SET^VALM10(VALMCNT," ** No "_$S(SDWLOPT=2:"in",1:"")_"active transfer details to display... ")
Q
HD ; -- Make header line for list processor
N X
S X=$$SETSTR^VALM1("User: "_SDWLDZN,"",1,79)
S VALMHDR(1)=X,VALMHDR(2)=""
Q
EXIT ; Tidy up
K VALMBCK,VALMHDR,VALMCNT
K SDWLDZN,SDWLSPS,SDWLINFO,SDWLOPT,SDWLFMT
K ^TMP("DILIST",$J),^TMP("SDWLIFT",$J)
Q
GETTRN(SDWLDA,SDWLINNM,SDWLSTN) ; Get transfer details for Electronic Wait List internal entry number
; Extrinsic boolean: 0: no active transfer, 1: active transfer.
; Input: SDWLDA: EWL IEN
; Output: SDWLINNM: Institution name
; SDWLSTN: Station Number
S (SDWLINNM,SDWLSTN)=""
Q:'$D(^SDWL(409.35,"B",SDWLDA)) 0
N SDWLIFTN,SDWLSTA,SDWLINST
S SDWLIFTN=$O(^SDWL(409.35,"B",SDWLDA,":"),-1),SDWLSTA=$$GET1^DIQ(409.35,SDWLIFTN,3,"I") ; Get the last transfer: a status of P, T or R can not have entries after.
Q:"^P^T^R^"'[("^"_SDWLSTA_"^") 0
S SDWLSTN=$$GET1^DIQ(409.35,SDWLIFTN,1),SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLINNM=$$GET1^DIQ(4,SDWLINST,60)
Q 1
SDWLIFT1 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REQUEST SUMMARY ; Compiled March 29, 2005 15:36:25
+1 ;;5.3;Scheduling;**415,1015**;AUG 13 1993;Build 21
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ;
+10 ;
+11 QUIT
EN ; INITIALIZE VARIABLES
+1 KILL ^TMP("SDWLIFT",$JOB)
+2 KILL DIR,DIC,DR,DIE,VADM
+3 SET SDWLFMT=0
+4 DO EN^VALM("SDWL TRANSFER REQ MAIN")
+5 QUIT
ENI ; INITIALIZE VARIABLES - Inactive entries
+1 NEW SDWLFMT
+2 KILL ^TMP("SDWLIFT",$JOB,"EP")
+3 KILL DIR,DIC,DR,DIE,VADM
+4 SET SDWLFMT=2
+5 DO EN^VALM("SDWL TRANSFER REQ INAC")
DO INIT(0)
+6 SET VALMBCK="R"
+7 QUIT
INIT(SDWLOPT) ; Default initialization options.
+1 KILL ^TMP("DILIST",$JOB),^TMP("SDWLIFT",$JOB)
+2 NEW SDWLINFO,SDWLI,DISPCNT
+3 IF '$DATA(DUZ)
WRITE !,"DUZ required for this option"
DO PAUSE^VALM1
QUIT
+4 SET SDWLDZN=$PIECE(^VA(200,DUZ,0),U)
+5 SET SDWLSPS=$JUSTIFY("",30)
+6 DO GETDATA^SDWLIFT5(.SDWLINFO,SDWLOPT)
+7 SET VALMCNT=0
+8 FOR DISPCNT=1:1:SDWLINFO(0)
Begin DoDot:1
+9 NEW SDWLOUT
+10 SET VALMCNT=VALMCNT+1
+11 ; Display count
+12 SET SDWLOUT=$EXTRACT(DISPCNT_SDWLSPS,1,3)
+13 ; Name
+14 SET SDWLOUT=SDWLOUT_$EXTRACT($PIECE(SDWLINFO(DISPCNT,0),U)_SDWLSPS,1,27)_" "
+15 ; SSN
+16 SET SDWLOUT=SDWLOUT_$EXTRACT($PIECE(SDWLINFO(DISPCNT,0),U,2)_SDWLSPS,1,12)_" "
+17 ; Destination Institution
+18 SET SDWLOUT=SDWLOUT_$EXTRACT($PIECE(SDWLINFO(DISPCNT,0),U,3)_SDWLSPS,1,20)_" "
+19 ; Transfer Status
+20 SET SDWLOUT=SDWLOUT_$PIECE(SDWLINFO(DISPCNT,0),U,4)
+21 DO SET^VALM10(VALMCNT,SDWLOUT)
+22 ; Line 2
+23 SET VALMCNT=VALMCNT+1
+24 ; Current Wait List Institution
+25 SET SDWLOUT=$EXTRACT($PIECE(SDWLINFO(DISPCNT,0),U,5)_SDWLSPS,1,30)_" "
+26 ; Current Wait List Type
+27 SET SDWLOUT=SDWLOUT_$PIECE(SDWLINFO(DISPCNT,0),U,6)_" : "
+28 ; Current Wait List Type Extension
+29 SET SDWLOUT=SDWLOUT_$PIECE(SDWLINFO(DISPCNT,0),U,7)
+30 DO SET^VALM10(VALMCNT,SDWLOUT)
+31 QUIT
End DoDot:1
+32 IF 'VALMCNT
SET VALMCNT=1
DO SET^VALM10(VALMCNT," ** No "_$SELECT(SDWLOPT=2:"in",1:"")_"active transfer details to display... ")
+33 QUIT
HD ; -- Make header line for list processor
+1 NEW X
+2 SET X=$$SETSTR^VALM1("User: "_SDWLDZN,"",1,79)
+3 SET VALMHDR(1)=X
SET VALMHDR(2)=""
+4 QUIT
EXIT ; Tidy up
+1 KILL VALMBCK,VALMHDR,VALMCNT
+2 KILL SDWLDZN,SDWLSPS,SDWLINFO,SDWLOPT,SDWLFMT
+3 KILL ^TMP("DILIST",$JOB),^TMP("SDWLIFT",$JOB)
+4 QUIT
GETTRN(SDWLDA,SDWLINNM,SDWLSTN) ; Get transfer details for Electronic Wait List internal entry number
+1 ; Extrinsic boolean: 0: no active transfer, 1: active transfer.
+2 ; Input: SDWLDA: EWL IEN
+3 ; Output: SDWLINNM: Institution name
+4 ; SDWLSTN: Station Number
+5 SET (SDWLINNM,SDWLSTN)=""
+6 IF '$DATA(^SDWL(409.35,"B",SDWLDA))
QUIT 0
+7 NEW SDWLIFTN,SDWLSTA,SDWLINST
+8 ; Get the last transfer: a status of P, T or R can not have entries after.
SET SDWLIFTN=$ORDER(^SDWL(409.35,"B",SDWLDA,":"),-1)
SET SDWLSTA=$$GET1^DIQ(409.35,SDWLIFTN,3,"I")
+9 IF "^P^T^R^"'[("^"_SDWLSTA_"^")
QUIT 0
+10 SET SDWLSTN=$$GET1^DIQ(409.35,SDWLIFTN,1)
SET SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D")
SET SDWLINNM=$$GET1^DIQ(4,SDWLINST,60)
+11 QUIT 1
