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

SDWLIFT1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. ;******************************************************************
  1. ; CHANGE LOG
  1. ;
  1. ; DATE PATCH DESCRIPTION
  1. ; ---- ----- -----------
  1. ;
  1. ;
  1. Q
  1. EN ; INITIALIZE VARIABLES
  1. K ^TMP("SDWLIFT",$J)
  1. K DIR,DIC,DR,DIE,VADM
  1. S SDWLFMT=0
  1. D EN^VALM("SDWL TRANSFER REQ MAIN")
  1. Q
  1. ENI ; INITIALIZE VARIABLES - Inactive entries
  1. N SDWLFMT
  1. K ^TMP("SDWLIFT",$J,"EP")
  1. K DIR,DIC,DR,DIE,VADM
  1. S SDWLFMT=2
  1. D EN^VALM("SDWL TRANSFER REQ INAC"),INIT(0)
  1. S VALMBCK="R"
  1. Q
  1. INIT(SDWLOPT) ; Default initialization options.
  1. K ^TMP("DILIST",$J),^TMP("SDWLIFT",$J)
  1. N SDWLINFO,SDWLI,DISPCNT
  1. I '$D(DUZ) W !,"DUZ required for this option" D PAUSE^VALM1 Q
  1. S SDWLDZN=$P(^VA(200,DUZ,0),U)
  1. S SDWLSPS=$J("",30)
  1. D GETDATA^SDWLIFT5(.SDWLINFO,SDWLOPT)
  1. S VALMCNT=0
  1. F DISPCNT=1:1:SDWLINFO(0) D
  1. .N SDWLOUT
  1. .S VALMCNT=VALMCNT+1
  1. .; Display count
  1. .S SDWLOUT=$E(DISPCNT_SDWLSPS,1,3)
  1. .; Name
  1. .S SDWLOUT=SDWLOUT_$E($P(SDWLINFO(DISPCNT,0),U)_SDWLSPS,1,27)_" "
  1. .; SSN
  1. .S SDWLOUT=SDWLOUT_$E($P(SDWLINFO(DISPCNT,0),U,2)_SDWLSPS,1,12)_" "
  1. .; Destination Institution
  1. .S SDWLOUT=SDWLOUT_$E($P(SDWLINFO(DISPCNT,0),U,3)_SDWLSPS,1,20)_" "
  1. .; Transfer Status
  1. .S SDWLOUT=SDWLOUT_$P(SDWLINFO(DISPCNT,0),U,4)
  1. .D SET^VALM10(VALMCNT,SDWLOUT)
  1. .; Line 2
  1. .S VALMCNT=VALMCNT+1
  1. .; Current Wait List Institution
  1. .S SDWLOUT=$E($P(SDWLINFO(DISPCNT,0),U,5)_SDWLSPS,1,30)_" "
  1. .; Current Wait List Type
  1. .S SDWLOUT=SDWLOUT_$P(SDWLINFO(DISPCNT,0),U,6)_" : "
  1. .; Current Wait List Type Extension
  1. .S SDWLOUT=SDWLOUT_$P(SDWLINFO(DISPCNT,0),U,7)
  1. .D SET^VALM10(VALMCNT,SDWLOUT)
  1. .Q
  1. I 'VALMCNT S VALMCNT=1 D SET^VALM10(VALMCNT," ** No "_$S(SDWLOPT=2:"in",1:"")_"active transfer details to display... ")
  1. Q
  1. HD ; -- Make header line for list processor
  1. N X
  1. S X=$$SETSTR^VALM1("User: "_SDWLDZN,"",1,79)
  1. S VALMHDR(1)=X,VALMHDR(2)=""
  1. Q
  1. EXIT ; Tidy up
  1. K VALMBCK,VALMHDR,VALMCNT
  1. K SDWLDZN,SDWLSPS,SDWLINFO,SDWLOPT,SDWLFMT
  1. K ^TMP("DILIST",$J),^TMP("SDWLIFT",$J)
  1. Q
  1. GETTRN(SDWLDA,SDWLINNM,SDWLSTN) ; Get transfer details for Electronic Wait List internal entry number
  1. ; Extrinsic boolean: 0: no active transfer, 1: active transfer.
  1. ; Input: SDWLDA: EWL IEN
  1. ; Output: SDWLINNM: Institution name
  1. ; SDWLSTN: Station Number
  1. S (SDWLINNM,SDWLSTN)=""
  1. Q:'$D(^SDWL(409.35,"B",SDWLDA)) 0
  1. N SDWLIFTN,SDWLSTA,SDWLINST
  1. 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.
  1. Q:"^P^T^R^"'[("^"_SDWLSTA_"^") 0
  1. S SDWLSTN=$$GET1^DIQ(409.35,SDWLIFTN,1),SDWLINST=$$FIND1^DIC(4,"","X",SDWLSTN,"D"),SDWLINNM=$$GET1^DIQ(4,SDWLINST,60)
  1. Q 1