SDWLIFT5.m

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,1015**;AUG 13 1993;Build 21

 ;

 ;

 ;******************************************************************

 ;                             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

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,1015**;AUG 13 1993;Build 21

 +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