SDWLIFT5 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: ACCEPT DATA - MAIN SCREEN ; Compiled March 29, 2005 15:26:24 ; Compiled January 26, 2007 10:05:24
;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 10/03/06 SD*5.3*446 Enhancements
;
Q
EN ; INITIALIZE VARIABLES
K DIR,DIC,DR,DIE,VADM,SDWLLIST,VALMHDR,VALMCNT,VALMBCK
D EN^VALM("SDWL TRANSFER ACC MAIN")
Q
INIT ; Default initialization options.
K ^TMP("DILIST",$J),^TMP("SDWLIFT",$J,"EP")
N SDWLI,DIC
S SDWLSPS=$J("",80)
S VALMCNT=0
D GETLIST F SDWLI=1:1:SDWLLIST(0) D
.N SDWLOUT
.S VALMCNT=VALMCNT+1
.S SDWLOUT=$E(VALMCNT_SDWLSPS,1,3)
.S SDWLOUT=SDWLOUT_$E($P(SDWLLIST(SDWLI,0),U)_SDWLSPS,1,26)_" "
.S SDWLOUT=SDWLOUT_$E($P(SDWLLIST(SDWLI,0),U,2)_SDWLSPS,1,21)_" "
.S SDWLOUT=SDWLOUT_$E($P(SDWLLIST(SDWLI,0),U,3)_SDWLSPS,1,25)_" "
.S SDWLOUT=SDWLOUT_$P(SDWLLIST(SDWLI,0),U,4)
.D SET^VALM10(VALMCNT,SDWLOUT)
.Q
I 'VALMCNT S VALMCNT=1 D SET^VALM10(VALMCNT," ** No transfer details... ")
Q
HD ; -- Make header line for list processor
S (VALMHDR(1),VALMHDR(2))=""
Q
EXIT ; Tidy up
K ^TMP("DILIST",$J),^TMP("SDWLIFT",$J,"EP")
K SDWLLIST,SDWLSPS,SDWLIFTN
Q
GETLIST ;
N SDWLI
S DIC=409.36
D LIST^DIC(DIC)
S (SDWLI,SDWLLIST(0))=0,DIC(0)="Z"
F S SDWLI=$O(^TMP("DILIST",$J,2,SDWLI)) Q:'SDWLI D
.N TMP,SDWLIFTN,SDWLST,DIC,D,X
.S SDWLIFTN=^TMP("DILIST",$J,2,SDWLI)
.D GETS^DIQ(409.36,SDWLIFTN,".01;.02;.03;.09;.1;.2;1",,"TMP")
.S SDWLST=$$GET1^DIQ(409.36,SDWLIFTN,1,"I")
.Q:SDWLST="C"!(SDWLST="R")!(SDWLST="T")
.S SDWLLIST(0)=SDWLLIST(0)+1
.S SDWLLIST(SDWLLIST(0),0)=TMP(409.36,SDWLIFTN_",",.01)
.S $P(SDWLLIST(SDWLLIST(0),0),U,2)=TMP(409.36,SDWLIFTN_",",.2) ; date/time
.S $P(SDWLLIST(SDWLLIST(0),0),U,3)=$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.36,SDWLIFTN_",",.1),"D"),.01)
.S $P(SDWLLIST(SDWLLIST(0),0),U,4)=SDWLST
.S SDWLLIST(SDWLLIST(0),1)=SDWLIFTN
.Q
Q
GETDATA(SDWLOUT,SDWLFMT) ; Get request data for display.
; SDWLFMT - output format: 0: filtered, only active transmissions
; 1: all transmissions
; 2: filtered, only inactive transmissions
N SDWLI,DIC,X,Y
S DIC=409.35
D LIST^DIC(DIC)
S (SDWLI,SDWLOUT(0))=0,DIC(0)="Z"
F S SDWLI=$O(^TMP("DILIST",$J,2,SDWLI)) Q:'SDWLI S X="`"_^TMP("DILIST",$J,2,SDWLI) D ^DIC I $D(Y(0)) D
.N REC,SDWLNAM,DFN,SDWLDA,SDWLSTA,TMP,SDWLIFTN,SDWLTY,SDWLTV,VADM,DIC,D,X
.S REC=Y(0),SDWLNAM=Y(0,0),SDWLDA=$P(Y(0),U),SDWLIFTN=+Y,DFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
.D GETS^DIQ(409.35,SDWLIFTN,"1;2;3;4",,"TMP")
.S SDWLSTA=TMP(409.35,SDWLIFTN_",",3),SDWLTV=SDWLSTA="RESOLVED"!(SDWLSTA="REFUSED")
.I 'SDWLFMT Q:SDWLTV ; Only show 'active' transmissions.
.I SDWLFMT=2 Q:'SDWLTV ; Only show 'inactive' transmissions.
.D DEM^VADPT
.D GETS^DIQ(409.3,SDWLDA,"2;4",,"TMP")
.S SDWLOUT(0)=SDWLOUT(0)+1
.S SDWLOUT(SDWLOUT(0),1)=SDWLIFTN
.; Name
.S SDWLOUT(SDWLOUT(0),0)=SDWLNAM
.; SSN
.S $P(SDWLOUT(SDWLOUT(0),0),U,2)=$P(VADM(2),U,2)
.; Destination Institution
.S $P(SDWLOUT(SDWLOUT(0),0),U,3)=$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.35,SDWLIFTN_",",1),"D"),.01)
.; Transfer Status
.S $P(SDWLOUT(SDWLOUT(0),0),U,4)=SDWLSTA
.; Current Wait List Institution
.S $P(SDWLOUT(SDWLOUT(0),0),U,5)=TMP(409.3,SDWLDA_",",2)
.; Current Wait List Type
.S $P(SDWLOUT(SDWLOUT(0),0),U,6)=TMP(409.3,SDWLDA_",",4)
.; Current Wait List Type Extension
.S SDWLTY=$$GET1^DIQ(409.3,SDWLDA,4,"I")
.S $P(SDWLOUT(SDWLOUT(0),0),U,7)=$$GET1^DIQ(409.3,SDWLDA,SDWLTY+4)
.; Sex
.S $P(SDWLOUT(SDWLOUT(0),0),U,8)=$P(VADM(5),U,2)
.; Transmission date/time
.S $P(SDWLOUT(SDWLOUT(0),0),U,9)=TMP(409.35,SDWLIFTN_",",2)
.; Requestor
.S $P(SDWLOUT(SDWLOUT(0),0),U,10)=TMP(409.35,SDWLIFTN_",",4)
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLIFT5 4117 printed Oct 16, 2024@19:03:13 Page 2
SDWLIFT5 ;IOFO BAY PINES/OG - INTER-FACILITY TRANSFER: ACCEPT DATA - MAIN SCREEN ; Compiled March 29, 2005 15:26:24 ; Compiled January 26, 2007 10:05:24
+1 ;;5.3;Scheduling;**415,446**;AUG 13 1993;Build 77
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 10/03/06 SD*5.3*446 Enhancements
+10 ;
+11 QUIT
EN ; INITIALIZE VARIABLES
+1 KILL DIR,DIC,DR,DIE,VADM,SDWLLIST,VALMHDR,VALMCNT,VALMBCK
+2 DO EN^VALM("SDWL TRANSFER ACC MAIN")
+3 QUIT
INIT ; Default initialization options.
+1 KILL ^TMP("DILIST",$JOB),^TMP("SDWLIFT",$JOB,"EP")
+2 NEW SDWLI,DIC
+3 SET SDWLSPS=$JUSTIFY("",80)
+4 SET VALMCNT=0
+5 DO GETLIST
FOR SDWLI=1:1:SDWLLIST(0)
Begin DoDot:1
+6 NEW SDWLOUT
+7 SET VALMCNT=VALMCNT+1
+8 SET SDWLOUT=$EXTRACT(VALMCNT_SDWLSPS,1,3)
+9 SET SDWLOUT=SDWLOUT_$EXTRACT($PIECE(SDWLLIST(SDWLI,0),U)_SDWLSPS,1,26)_" "
+10 SET SDWLOUT=SDWLOUT_$EXTRACT($PIECE(SDWLLIST(SDWLI,0),U,2)_SDWLSPS,1,21)_" "
+11 SET SDWLOUT=SDWLOUT_$EXTRACT($PIECE(SDWLLIST(SDWLI,0),U,3)_SDWLSPS,1,25)_" "
+12 SET SDWLOUT=SDWLOUT_$PIECE(SDWLLIST(SDWLI,0),U,4)
+13 DO SET^VALM10(VALMCNT,SDWLOUT)
+14 QUIT
End DoDot:1
+15 IF 'VALMCNT
SET VALMCNT=1
DO SET^VALM10(VALMCNT," ** No transfer details... ")
+16 QUIT
HD ; -- Make header line for list processor
+1 SET (VALMHDR(1),VALMHDR(2))=""
+2 QUIT
EXIT ; Tidy up
+1 KILL ^TMP("DILIST",$JOB),^TMP("SDWLIFT",$JOB,"EP")
+2 KILL SDWLLIST,SDWLSPS,SDWLIFTN
+3 QUIT
GETLIST ;
+1 NEW SDWLI
+2 SET DIC=409.36
+3 DO LIST^DIC(DIC)
+4 SET (SDWLI,SDWLLIST(0))=0
SET DIC(0)="Z"
+5 FOR
SET SDWLI=$ORDER(^TMP("DILIST",$JOB,2,SDWLI))
if 'SDWLI
QUIT
Begin DoDot:1
+6 NEW TMP,SDWLIFTN,SDWLST,DIC,D,X
+7 SET SDWLIFTN=^TMP("DILIST",$JOB,2,SDWLI)
+8 DO GETS^DIQ(409.36,SDWLIFTN,".01;.02;.03;.09;.1;.2;1",,"TMP")
+9 SET SDWLST=$$GET1^DIQ(409.36,SDWLIFTN,1,"I")
+10 if SDWLST="C"!(SDWLST="R")!(SDWLST="T")
QUIT
+11 SET SDWLLIST(0)=SDWLLIST(0)+1
+12 SET SDWLLIST(SDWLLIST(0),0)=TMP(409.36,SDWLIFTN_",",.01)
+13 ; date/time
SET $PIECE(SDWLLIST(SDWLLIST(0),0),U,2)=TMP(409.36,SDWLIFTN_",",.2)
+14 SET $PIECE(SDWLLIST(SDWLLIST(0),0),U,3)=$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.36,SDWLIFTN_",",.1),"D"),.01)
+15 SET $PIECE(SDWLLIST(SDWLLIST(0),0),U,4)=SDWLST
+16 SET SDWLLIST(SDWLLIST(0),1)=SDWLIFTN
+17 QUIT
End DoDot:1
+18 QUIT
GETDATA(SDWLOUT,SDWLFMT) ; Get request data for display.
+1 ; SDWLFMT - output format: 0: filtered, only active transmissions
+2 ; 1: all transmissions
+3 ; 2: filtered, only inactive transmissions
+4 NEW SDWLI,DIC,X,Y
+5 SET DIC=409.35
+6 DO LIST^DIC(DIC)
+7 SET (SDWLI,SDWLOUT(0))=0
SET DIC(0)="Z"
+8 FOR
SET SDWLI=$ORDER(^TMP("DILIST",$JOB,2,SDWLI))
if 'SDWLI
QUIT
SET X="`"_^TMP("DILIST",$JOB,2,SDWLI)
DO ^DIC
IF $DATA(Y(0))
Begin DoDot:1
+9 NEW REC,SDWLNAM,DFN,SDWLDA,SDWLSTA,TMP,SDWLIFTN,SDWLTY,SDWLTV,VADM,DIC,D,X
+10 SET REC=Y(0)
SET SDWLNAM=Y(0,0)
SET SDWLDA=$PIECE(Y(0),U)
SET SDWLIFTN=+Y
SET DFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
+11 DO GETS^DIQ(409.35,SDWLIFTN,"1;2;3;4",,"TMP")
+12 SET SDWLSTA=TMP(409.35,SDWLIFTN_",",3)
SET SDWLTV=SDWLSTA="RESOLVED"!(SDWLSTA="REFUSED")
+13 ; Only show 'active' transmissions.
IF 'SDWLFMT
if SDWLTV
QUIT
+14 ; Only show 'inactive' transmissions.
IF SDWLFMT=2
if 'SDWLTV
QUIT
+15 DO DEM^VADPT
+16 DO GETS^DIQ(409.3,SDWLDA,"2;4",,"TMP")
+17 SET SDWLOUT(0)=SDWLOUT(0)+1
+18 SET SDWLOUT(SDWLOUT(0),1)=SDWLIFTN
+19 ; Name
+20 SET SDWLOUT(SDWLOUT(0),0)=SDWLNAM
+21 ; SSN
+22 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,2)=$PIECE(VADM(2),U,2)
+23 ; Destination Institution
+24 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,3)=$$GET1^DIQ(4,$$FIND1^DIC(4,"","X",TMP(409.35,SDWLIFTN_",",1),"D"),.01)
+25 ; Transfer Status
+26 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,4)=SDWLSTA
+27 ; Current Wait List Institution
+28 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,5)=TMP(409.3,SDWLDA_",",2)
+29 ; Current Wait List Type
+30 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,6)=TMP(409.3,SDWLDA_",",4)
+31 ; Current Wait List Type Extension
+32 SET SDWLTY=$$GET1^DIQ(409.3,SDWLDA,4,"I")
+33 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,7)=$$GET1^DIQ(409.3,SDWLDA,SDWLTY+4)
+34 ; Sex
+35 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,8)=$PIECE(VADM(5),U,2)
+36 ; Transmission date/time
+37 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,9)=TMP(409.35,SDWLIFTN_",",2)
+38 ; Requestor
+39 SET $PIECE(SDWLOUT(SDWLOUT(0),0),U,10)=TMP(409.35,SDWLIFTN_",",4)
+40 QUIT
End DoDot:1
+41 QUIT
