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 ---[H[J[2J[HDVBADXFR 4383 printed Apr 09, 2024@20:50:42 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
