- SDWLIFT1 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REQUEST SUMMARY ; Compiled March 29, 2005 15:36:25
- ;;5.3;Scheduling;**415**;AUG 13 1993
- ;
- ;
- ;******************************************************************
- ; 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLIFT1 2995 printed Jan 18, 2025@04:03:57 Page 2
- SDWLIFT1 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: REQUEST SUMMARY ; Compiled March 29, 2005 15:36:25
- +1 ;;5.3;Scheduling;**415**;AUG 13 1993
- +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