DVBADXFR.m

DVBADXFR ;ALB/GTS-AMIE 7131 DIVISIONAL TRANSFER RTN ; 12/6/94  2:00 PM

 ;;2.7;AMIE;;Apr 10, 1995

 ;

MAIN ;**Loop to select and update 7131 report divisions

 F  DO  I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q  ;**QUIT top 'For' loop

 .D HOME^%ZIS

 .W @IOF

 .W !!,?5,"7131 Divisional Transfer",!!

 .S REQDA=$$SEL7131^DVBAUTL7()

 .S:+REQDA'>0 DVBAOUT=""

 .I +REQDA>0 DO

 ..D INITIAL,REQVARS

 ..D INITRPT^DVBAUTL7(REQDA)

 ..K DTOUT,DUOUT,DVBAOUT

 ..F  DO  I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q  ;**QUIT 'For' loop

 ...K NODIV

 ...D DRAW

 ...D READ I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q  ;**QUIT 'For' loop

 ...D DIVSEL I $D(DTOUT)!($D(DUOUT)!($D(DVBAOUT))) Q  ;**QUIT 'For' loop

 ...D:'$D(NODIV) ADJ

 ..I '$D(DTOUT)&('$D(DUOUT)) D FILE^DVBAUTL7

 ..D EXITLP

 K DVBAOUT,REQDA,DA,DIE,DIR,DR,DTOUT,DUOUT

 W @IOF

 Q

 ;

EXITLP K A,DA,DIE,DIR,DR,DTOUT,DUOUT,DVBADSCH,DVBAER,DVBAHD21,DVBALN,DVBAOUT

 K FLDDIV,FLDDTE,REQDIV,DVBARPT,DVBATDT,DVBATITL,DVBAX,X,Z,DVBAP,DVBAO

 K REQDTE,DVBARPT,REQDA,DVBCSSNO,SSN,HNAME,PNAM,DVBREQDT,DFN,RPTVAR

 K NDIVIEN,NDIVNAME,CNUM,NODIV

 Q

 ;

INITIAL ;**initialize general variables

 S $P(DVBALN,"-",80)=""

 S DVBATITL="7131 Divisional Transfer"

 S X="NOW",%DT="ST"

 D ^%DT

 X ^DD("DD")

 S DVBATDT=Y

 S HNAME=$$SITE^DVBCUTL4()

 K X,Y,%DT

 Q

 ;

REQVARS ;**Set variables unique to 7131

 S DVBREQDT=$P(^DVB(396,REQDA,0),U,4)

 I $P(^DVB(396,REQDA,2),U,10)="L" D ACT

 I $P(^DVB(396,REQDA,2),U,10)="A" D ADM

 S DFN=$P(^DVB(396,REQDA,0),U,1)

 S PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^DPT(+DFN,0),U,9)

 S CNUM=$S($D(^DPT(+DFN,.31)):$P(^(.31),U,3),1:"Unknown")

 D SSNOUT^DVBCUTIL

 S SSN=DVBCSSNO

 Q

 ;

ADM ;**Set up admission date and discharge variables

 S Y=DVBREQDT

 D DD^%DT

 S DVBAHD21="Admission Date: "_Y

 K Y

 Q

 ;

ACT ;**Set up activity date variable

 S Y=DVBREQDT

 D DD^%DT

 S DVBAHD21="Activity Date: "_Y

 K Y

 Q

 ;

DRAW ;** Output Division screen

 I IOST?1"C-".E W @IOF

 W "Information Request Form"

 W ?35,HNAME

 W ?59,DVBATDT

 W !,DVBALN

 W !,"Patient: "

 W PNAM

 W ?54,"SSN: "

 W SSN

 W !,"Claim #: ",CNUM,!

 W DVBAHD21

 W !!,?9,"Report",?37,"Selected",?48,"Status",?58,"Division"

 W !,DVBALN

 F DVBAX=0:0 S DVBAX=$O(DVBARPT(DVBAX)) Q:'DVBAX  D DRAW1

 W !,DVBALN

 Q

 ;

DRAW1 ;** Output a report to the screen

 W !,DVBAX

 W ?3,$P(DVBARPT(DVBAX),U,1)

 W ?40,$S($P(DVBARPT(DVBAX),U,2)["Y":"YES",1:"NO")

 W ?48,$S($P(DVBARPT(DVBAX),U,3)="C":"Completed",$P(DVBARPT(DVBAX),U,3)="P":"Pending",1:"")

 W ?58,$E($P(DVBARPT(DVBAX),U,4),1,20)

 Q

 ;

READ ;** Read selected report

 S DIR(0)="LAO^1:11^K:X[""."" X"

 S DIR("A")="Select Report(s) to Transfer: "

 S DIR("?",1)="Select a number or range of numbers from 1 to 10 (1,3,5 or 2-4,8).  You will"

 S DIR("?",2)="then be asked to select a division to transfer the report(s) to.  After a"

 S DIR("?")="division is selected, the new division will display next to the report(s)."

 D ^DIR

 I $D(DUOUT)!($D(DTOUT)) Q

 I 'Y S DVBAOUT="" ;**User hit Return at report prompt

 S:$D(Y) RPTVAR=Y

 Q

 ;

DIVSEL ;** Select a division to transfer to  (Division must be in AMIE Site

 ;**  Parameter File)

 N PARAMDA

 S PARAMDA=$$IFNPAR^DVBAUTL3()

 D:PARAMDA'>0 PARAMERR

 I PARAMDA>0 DO

 .S DIC(0)="AEMQ"

 .S DIC("A")="Select a Division to Transfer to: "

 .S DIC="^DVB(396.1,PARAMDA,2,"

 .D ^DIC

 .S:+Y>0 NDIVIEN=$P(^DVB(396.1,PARAMDA,2,+Y,0),U,1)

 .S:+Y>0 NDIVNAME=$P(^DG(40.8,NDIVIEN,0),U,1)

 .S:+Y'>0 NODIV=""

 .K DIC,Y

 Q

 ;

PARAMERR ;** Error if the AMIE Site Parameter file has a problem

 W *7,!,"The AMIE Site Parameter File is not set up properly."

 W !,"Contact the Medical Center's IRM department."

 W !,?30,"<Return> to continue."

 R Z:DTIME

 S DVBAOUT=""

 Q

 ;

ADJ ;** Adjust local array DVBARPT(#)

 K DVBAER

 N X,A

 F X=1:1:11 S A=$P(RPTVAR,",",X) Q:'A  D CHECK

 D:'$D(DVBAER) CHNG

 K Y

 Q

 ;

CHECK ;** Check for X-fer of report with status '= Pending

 I $P(DVBARPT(A),U,3)'="P" DO:'$D(DVBAER)  S DVBAER=1 Q

 .W *7,!,"You have selected a report with a status other than Pending."

 .W !,"All reports selected for transfer must be Pending."

 .W !,?30,"<Return> to continue."

 .R Z:DTIME

 .Q

 Q

 ;

CHNG ;** Update local array DVBARPT(#)

 F X=1:1:11 S A=$P(RPTVAR,",",X) Q:'A  DO

 .I $P(DVBARPT(A),U,3)="P" DO

 ..S $P(DVBARPT(A),U,4)=NDIVNAME

 ..S $P(DVBARPT(A),U,5)=NDIVIEN

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVBADXFR   4383     printed  Apr 23, 2025@17:55:37                                                                                                                                                                                                    Page 2

DVBADXFR  ;ALB/GTS-AMIE 7131 DIVISIONAL TRANSFER RTN ; 12/6/94  2:00 PM

 +1       ;;2.7;AMIE;;Apr 10, 1995

 +2       ;

MAIN      ;**Loop to select and update 7131 report divisions

 +1       ;**QUIT top 'For' loop

           FOR 

               Begin DoDot:1

 +2                DO HOME^%ZIS

 +3                WRITE @IOF

 +4                WRITE !!,?5,"7131 Divisional Transfer",!!

 +5                SET REQDA=$$SEL7131^DVBAUTL7()

 +6                if +REQDA'>0

                       SET DVBAOUT=""

 +7                IF +REQDA>0

                       Begin DoDot:2

 +8                        DO INITIAL

                           DO REQVARS

 +9                        DO INITRPT^DVBAUTL7(REQDA)

 +10                       KILL DTOUT,DUOUT,DVBAOUT

 +11      ;**QUIT 'For' loop

                           FOR 

                               Begin DoDot:3

 +12                               KILL NODIV

 +13                               DO DRAW

 +14      ;**QUIT 'For' loop

                                   DO READ

                                   IF $DATA(DTOUT)!($DATA(DUOUT)!($DATA(DVBAOUT)))

                                       QUIT 

 +15      ;**QUIT 'For' loop

                                   DO DIVSEL

                                   IF $DATA(DTOUT)!($DATA(DUOUT)!($DATA(DVBAOUT)))

                                       QUIT 

 +16                               if '$DATA(NODIV)

                                       DO ADJ

                               End DoDot:3

                               IF $DATA(DTOUT)!($DATA(DUOUT)!($DATA(DVBAOUT)))

                                   QUIT 

 +17                       IF '$DATA(DTOUT)&('$DATA(DUOUT))

                               DO FILE^DVBAUTL7

 +18                       DO EXITLP

                       End DoDot:2

               End DoDot:1

               IF $DATA(DTOUT)!($DATA(DUOUT)!($DATA(DVBAOUT)))

                   QUIT 

 +19       KILL DVBAOUT,REQDA,DA,DIE,DIR,DR,DTOUT,DUOUT

 +20       WRITE @IOF

 +21       QUIT 

 +22      ;

EXITLP     KILL A,DA,DIE,DIR,DR,DTOUT,DUOUT,DVBADSCH,DVBAER,DVBAHD21,DVBALN,DVBAOUT

 +1        KILL FLDDIV,FLDDTE,REQDIV,DVBARPT,DVBATDT,DVBATITL,DVBAX,X,Z,DVBAP,DVBAO

 +2        KILL REQDTE,DVBARPT,REQDA,DVBCSSNO,SSN,HNAME,PNAM,DVBREQDT,DFN,RPTVAR

 +3        KILL NDIVIEN,NDIVNAME,CNUM,NODIV

 +4        QUIT 

 +5       ;

INITIAL   ;**initialize general variables

 +1        SET $PIECE(DVBALN,"-",80)=""

 +2        SET DVBATITL="7131 Divisional Transfer"

 +3        SET X="NOW"

           SET %DT="ST"

 +4        DO ^%DT

 +5        XECUTE ^DD("DD")

 +6        SET DVBATDT=Y

 +7        SET HNAME=$$SITE^DVBCUTL4()

 +8        KILL X,Y,%DT

 +9        QUIT 

 +10      ;

REQVARS   ;**Set variables unique to 7131

 +1        SET DVBREQDT=$PIECE(^DVB(396,REQDA,0),U,4)

 +2        IF $PIECE(^DVB(396,REQDA,2),U,10)="L"

               DO ACT

 +3        IF $PIECE(^DVB(396,REQDA,2),U,10)="A"

               DO ADM

 +4        SET DFN=$PIECE(^DVB(396,REQDA,0),U,1)

 +5        SET PNAM=$PIECE(^DPT(DFN,0),U,1)

           SET SSN=$PIECE(^DPT(+DFN,0),U,9)

 +6        SET CNUM=$SELECT($DATA(^DPT(+DFN,.31)):$PIECE(^(.31),U,3),1:"Unknown")

 +7        DO SSNOUT^DVBCUTIL

 +8        SET SSN=DVBCSSNO

 +9        QUIT 

 +10      ;

ADM       ;**Set up admission date and discharge variables

 +1        SET Y=DVBREQDT

 +2        DO DD^%DT

 +3        SET DVBAHD21="Admission Date: "_Y

 +4        KILL Y

 +5        QUIT 

 +6       ;

ACT       ;**Set up activity date variable

 +1        SET Y=DVBREQDT

 +2        DO DD^%DT

 +3        SET DVBAHD21="Activity Date: "_Y

 +4        KILL Y

 +5        QUIT 

 +6       ;

DRAW      ;** Output Division screen

 +1        IF IOST?1"C-".E

               WRITE @IOF

 +2        WRITE "Information Request Form"

 +3        WRITE ?35,HNAME

 +4        WRITE ?59,DVBATDT

 +5        WRITE !,DVBALN

 +6        WRITE !,"Patient: "

 +7        WRITE PNAM

 +8        WRITE ?54,"SSN: "

 +9        WRITE SSN

 +10       WRITE !,"Claim #: ",CNUM,!

 +11       WRITE DVBAHD21

 +12       WRITE !!,?9,"Report",?37,"Selected",?48,"Status",?58,"Division"

 +13       WRITE !,DVBALN

 +14       FOR DVBAX=0:0

               SET DVBAX=$ORDER(DVBARPT(DVBAX))

               if 'DVBAX

                   QUIT 

               DO DRAW1

 +15       WRITE !,DVBALN

 +16       QUIT 

 +17      ;

DRAW1     ;** Output a report to the screen

 +1        WRITE !,DVBAX

 +2        WRITE ?3,$PIECE(DVBARPT(DVBAX),U,1)

 +3        WRITE ?40,$SELECT($PIECE(DVBARPT(DVBAX),U,2)["Y":"YES",1:"NO")

 +4        WRITE ?48,$SELECT($PIECE(DVBARPT(DVBAX),U,3)="C":"Completed",$PIECE(DVBARPT(DVBAX),U,3)="P":"Pending",1:"")

 +5        WRITE ?58,$EXTRACT($PIECE(DVBARPT(DVBAX),U,4),1,20)

 +6        QUIT 

 +7       ;

READ      ;** Read selected report

 +1        SET DIR(0)="LAO^1:11^K:X[""."" X"

 +2        SET DIR("A")="Select Report(s) to Transfer: "

 +3        SET DIR("?",1)="Select a number or range of numbers from 1 to 10 (1,3,5 or 2-4,8).  You will"

 +4        SET DIR("?",2)="then be asked to select a division to transfer the report(s) to.  After a"

 +5        SET DIR("?")="division is selected, the new division will display next to the report(s)."

 +6        DO ^DIR

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))

               QUIT 

 +8       ;**User hit Return at report prompt

           IF 'Y

               SET DVBAOUT=""

 +9        if $DATA(Y)

               SET RPTVAR=Y

 +10       QUIT 

 +11      ;

DIVSEL    ;** Select a division to transfer to  (Division must be in AMIE Site

 +1       ;**  Parameter File)

 +2        NEW PARAMDA

 +3        SET PARAMDA=$$IFNPAR^DVBAUTL3()

 +4        if PARAMDA'>0

               DO PARAMERR

 +5        IF PARAMDA>0

               Begin DoDot:1

 +6                SET DIC(0)="AEMQ"

 +7                SET DIC("A")="Select a Division to Transfer to: "

 +8                SET DIC="^DVB(396.1,PARAMDA,2,"

 +9                DO ^DIC

 +10               if +Y>0

                       SET NDIVIEN=$PIECE(^DVB(396.1,PARAMDA,2,+Y,0),U,1)

 +11               if +Y>0

                       SET NDIVNAME=$PIECE(^DG(40.8,NDIVIEN,0),U,1)

 +12               if +Y'>0

                       SET NODIV=""

 +13               KILL DIC,Y

               End DoDot:1

 +14       QUIT 

 +15      ;

PARAMERR  ;** Error if the AMIE Site Parameter file has a problem

 +1        WRITE *7,!,"The AMIE Site Parameter File is not set up properly."

 +2        WRITE !,"Contact the Medical Center's IRM department."

 +3        WRITE !,?30,"<Return> to continue."

 +4        READ Z:DTIME

 +5        SET DVBAOUT=""

 +6        QUIT 

 +7       ;

ADJ       ;** Adjust local array DVBARPT(#)

 +1        KILL DVBAER

 +2        NEW X,A

 +3        FOR X=1:1:11

               SET A=$PIECE(RPTVAR,",",X)

               if 'A

                   QUIT 

               DO CHECK

 +4        if '$DATA(DVBAER)

               DO CHNG

 +5        KILL Y

 +6        QUIT 

 +7       ;

CHECK     ;** Check for X-fer of report with status '= Pending

 +1        IF $PIECE(DVBARPT(A),U,3)'="P"

               if '$DATA(DVBAER)

                   Begin DoDot:1

 +2                    WRITE *7,!,"You have selected a report with a status other than Pending."

 +3                    WRITE !,"All reports selected for transfer must be Pending."

 +4                    WRITE !,?30,"<Return> to continue."

 +5                    READ Z:DTIME

 +6                    QUIT 

                   End DoDot:1

               SET DVBAER=1

               QUIT 

 +7        QUIT 

 +8       ;

CHNG      ;** Update local array DVBARPT(#)

 +1        FOR X=1:1:11

               SET A=$PIECE(RPTVAR,",",X)

               if 'A

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE(DVBARPT(A),U,3)="P"

                       Begin DoDot:2

 +3                        SET $PIECE(DVBARPT(A),U,4)=NDIVNAME

 +4                        SET $PIECE(DVBARPT(A),U,5)=NDIVIEN

                       End DoDot:2

               End DoDot:1

 +5        QUIT