DVBARQP ;ALB/JLU-7131 request processing routine ;1/28/93
;;2.7;AMIE;**32**;Apr 10, 1995
BEG ;
D INITIAL
D INITRPT^DVBAUTL3
F DO I DVBANY>0!($D(DTOUT)) Q
.S DVBAOUT=0
.F DO I $D(DTOUT)!($D(DUOUT))!(DVBAOUT) Q
..D DRAW
..D READ I $D(DTOUT)!($D(DUOUT))!(DVBAOUT) Q
..D ADJ
..Q
.D FILE
.Q
D EXIT
Q
;
EXIT K A,ADMNUM,DA,DIE,DIR,DR,DTOUT,DUOUT,DVBADSCH,DVBAER,DVBAHD21,DVBAHD22,DVBALN,DVBAOLD,DVBAOUT,DVBARPT,DVBATDT,DVBATITL,DVBAX,X,Z,DVBAP,DVBAO,DVBANY
Q
;
INITIAL ;This subroutine will initialize most of the variable needed for this
;option.
S $P(DVBALN,"-",80)=""
S DVBATITL="7131 Report Requesting"
S X="NOW",%DT="ST"
D ^%DT
X ^DD("DD")
S DVBATDT=Y
I $D(ADMNUM) D ADM
I DVBDOC="L" D ACT
D SSNOUT^DVBCUTIL
S SSN=DVBCSSNO
S DVBANY=0
Q
;
ADM ;sets up admission date variable and discharge variable if applicable
S Y=DVBREQDT
D DD^%DT
S DVBAHD21="Admission Date: "_Y
I '$D(^DGPM(+ADMNUM,0)) K Y Q
I $P(^DGPM(+ADMNUM,0),U,17)]"" DO
.S Y=$P(^(0),U,17) ;naked from line before
.S Y=$P(^DGPM(+Y,0),U,1)
.D DD^%DT
.S DVBADSCH=Y
.S DVBAHD22="Discharge Date: "_Y
.Q
K Y
Q
;
ACT ;sets up activity date variable
S Y=DVBREQDT
D DD^%DT
S DVBAHD21="Activity Date: "_Y
K Y
Q
;
DRAW ;This subroutine will draw the 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:$D(DVBAHD22) ?40,DVBAHD22
W !!,?9,"Report",?37,"Selected",?60,"Status"
W !,DVBALN
F DVBAX=0:0 S DVBAX=$O(DVBARPT(DVBAX)) Q:'DVBAX D DRAW1
W !,DVBALN
Q
;
DRAW1 ;rights the reports 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 ?60,$S($P(DVBARPT(DVBAX),U,3)="C":"Completed",$P(DVBARPT(DVBAX),U,3)="P":"Pending",1:"")
Q
;
READ ;reads the user answer
S DIR(0)="LAO^1:10^K:X[""."" X"
S DIR("A")="Select Report: "
S DIR("?",1)="Select a number or range of numbers from 1 to 10 (1,3,5 or 2-4,8). This will"
S DIR("?",2)="initially mark the report as 'YES'. If the number is selected again then it"
S DIR("?")="will be changed to 'NO' or vice versa"
D ^DIR
I $D(DUOUT)!($D(DTOUT)) Q
I 'Y S DVBAOUT=1
Q
;
ADJ ;This subroutine adjusts the local array
K DVBAER
N X,A,FLOP
F X=1:1:10 S A=$P(Y,",",X) Q:'A D DISC
Q
;
DISC ;checks for bad answers
I $D(ADMNUM),$D(DVBADSCH),A=1 DO:'$D(DVBAER) S DVBAER=1 Q
.W *7,!,"Vet already discharged - you cannot request Notice of Discharge."
.W !,?30,"<Return> to continue."
.R Z:DTIME
.Q
I DVBDOC="L",(A=1!(A=2)!(A=3)!(A=9)) DO:'$D(DVBAER) S DVBAER=1 Q
.W *7,!,"Cannot select 'Notice of Discharge', 'Hospital Summary', 'Certificate (21-day)', or 'Admission Report' for an activity date."
. W !,?30,"<Return> to continue."
.R Z:DTIME
.Q
;
;If Notice of Discharge selected, check patient's Claim Folder Location.
I A=1 S FLOP=0 D Q:FLOP
. N CK S CK=$$CKCFLOC()
. I CK=1 S FLOP=1 W *7,!,"The patient has no Claim Folder Location in the Patient File.",!,"Notice of Discharge would not be returned.",!,?30,"<Return> to continue." R Z:DTIME
. I CK=2 S FLOP=1 D
.. W *7,!,"The patient's Claim Folder Location has no Station Number in file #4.",!,"Notice of Discharge would not be returned.",!,"Please check the Claim Folder Location and its entry in file #4.",!,?30,"<Return> to continue." R Z:DTIME
;
;If 21 Day Certificate selected, check patient's Claim Folder Location.
I A=3 S FLOP=0 D Q:FLOP
. N CK S CK=$$CKCFLOC()
. I CK=1 S FLOP=1 W *7,!,"The patient has no Claim Folder Location in the Patient File.",!,"21 Day Certificate would not be returned.",!,?30,"<Return> to continue." R Z:DTIME
. I CK=2 S FLOP=1 D
.. W *7,!,"The patient's Claim Folder Location has no Station Number in file #4.",!,"21 Day Certificate would not be returned.",!,"Please check the Claim Folder Location and its entry in file #4.",!,?30,"<Return> to continue." R Z:DTIME
D CHNG
Q
;
CKCFLOC() ;Check if Claim Folder Location or its Station Number is null.
;If Claim Folder Location and Station Number are not null, CK=0.
;If Claim Folder Location is null, CK=1.
;If Station Number is null, CK=2.
N CK,ZDFN,ZCFLOC
S CK=0
S ZDFN=$P($G(DFN),U) I $G(ZDFN)="" S CK=3 Q CK
S ZCFLOC=$P($G(^DPT(ZDFN,.31)),U,4)
I $G(ZCFLOC)="" S CK=1
I $G(ZCFLOC)'="" S:$P($G(^DIC(4,ZCFLOC,99)),U)="" CK=2
Q CK
;
CHNG ;updates the local array
Q:$P(DVBARPT(A),U,3)["C"
S DVBAOLD=$P(DVBARPT(A),U,2)
S DVBAOLD=$S(DVBAOLD["Y":"NO",1:"YES")
S $P(DVBARPT(A),U,2)=DVBAOLD
S $P(DVBARPT(A),U,3)=$S(DVBAOLD["Y":"P",1:"")
Q
;
FILE ;this subroutine sets the data into the file and asks the last three
;questions
I $D(DTOUT) S DVBANY=1 D DEL^DVBAUTL3(DVBAENTR):'$D(DVBAEDT) Q
I $D(DUOUT) DO Q
.I '$D(DVBAEDT) S DVBANY=1 D DEL^DVBAUTL3(DVBAENTR) Q
.S DVBANY=$$ANYSEL(DVBAENTR)
.I DVBANY'>0 D ERR
.Q
D LAST
I $D(Y) I '$D(DVBAEDT) DO Q
.D DEL^DVBAUTL3(DVBAENTR)
.S DVBANY=1
.Q
S DVBANY=$$ANYSEL(DVBAENTR)
I 'DVBANY D ERR Q
D STM^DVBCUTL4
D FILE^DVBAUTL3
S XRTN=$T(+0)
D SPM^DVBCUTL4
;;;D TEST:'$D(DVBAEDT)
Q
;
ERR ;this subroutine will print out an error message when no reports are
;selected on the 7131.
S VAR(1,0)="1,0,0,2,0^You have not selected any reports for this 7131 request"
S VAR(2,0)="0,0,0,1:2,0^or have selected number 4 but not entered any remarks."
D WR^DVBAUTL4("VAR")
K VAR
D CONTMES^DVBCUTL4
Q
;
ANYSEL(B) ;
;This subroutine checks to see if any reports were selected on the 7131
;request.
;B is the internal entry number in file 396
N X,CNT
S CNT=0
F X=0:0 S X=$O(DVBARPT(X)) Q:'X!(CNT) DO ;checking each report
. I $P(DVBARPT(X),U,2)="YES" S CNT=1
.Q
I $P(^DVB(396,B,0),U,25)]"" S CNT=1 ;checking opt date range
I $P(DVBARPT(4),U,2)="YES",'$O(^DVB(396,B,5,0)) S CNT=0 ;if no remarks set to zero
Q CNT
;
LAST ;this subroutine will ask the last three questions
S DIE="^DVB(396,",DA=DVBAENTR
S DR="18;S X=X;19///^S X=$S($P(^DVB(396,DA,0),U,25)']"""":""@"",$P(^(0),U,26)=""C"":""C"",1:""P"");29Routing Location;.5;23///"_DT_";24///"_DT_";27///"_LOC_";28///"_OPER
D ^DIE
Q
;
TEST ;tests to see if the user wants this 7131
D DRAW
W !,*7,"Do you want to file this request"
S %=1 D YN^DICN
I %=2 D DEL^DVBAUTL3(DVBAENTR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBARQP 6430 printed Dec 13, 2024@01:42:08 Page 2
DVBARQP ;ALB/JLU-7131 request processing routine ;1/28/93
+1 ;;2.7;AMIE;**32**;Apr 10, 1995
BEG ;
+1 DO INITIAL
+2 DO INITRPT^DVBAUTL3
+3 FOR
Begin DoDot:1
+4 SET DVBAOUT=0
+5 FOR
Begin DoDot:2
+6 DO DRAW
+7 DO READ
IF $DATA(DTOUT)!($DATA(DUOUT))!(DVBAOUT)
QUIT
+8 DO ADJ
+9 QUIT
End DoDot:2
IF $DATA(DTOUT)!($DATA(DUOUT))!(DVBAOUT)
QUIT
+10 DO FILE
+11 QUIT
End DoDot:1
IF DVBANY>0!($DATA(DTOUT))
QUIT
+12 DO EXIT
+13 QUIT
+14 ;
EXIT KILL A,ADMNUM,DA,DIE,DIR,DR,DTOUT,DUOUT,DVBADSCH,DVBAER,DVBAHD21,DVBAHD22,DVBALN,DVBAOLD,DVBAOUT,DVBARPT,DVBATDT,DVBATITL,DVBAX,X,Z,DVBAP,DVBAO,DVBANY
+1 QUIT
+2 ;
INITIAL ;This subroutine will initialize most of the variable needed for this
+1 ;option.
+2 SET $PIECE(DVBALN,"-",80)=""
+3 SET DVBATITL="7131 Report Requesting"
+4 SET X="NOW"
SET %DT="ST"
+5 DO ^%DT
+6 XECUTE ^DD("DD")
+7 SET DVBATDT=Y
+8 IF $DATA(ADMNUM)
DO ADM
+9 IF DVBDOC="L"
DO ACT
+10 DO SSNOUT^DVBCUTIL
+11 SET SSN=DVBCSSNO
+12 SET DVBANY=0
+13 QUIT
+14 ;
ADM ;sets up admission date variable and discharge variable if applicable
+1 SET Y=DVBREQDT
+2 DO DD^%DT
+3 SET DVBAHD21="Admission Date: "_Y
+4 IF '$DATA(^DGPM(+ADMNUM,0))
KILL Y
QUIT
+5 IF $PIECE(^DGPM(+ADMNUM,0),U,17)]""
Begin DoDot:1
+6 ;naked from line before
SET Y=$PIECE(^(0),U,17)
+7 SET Y=$PIECE(^DGPM(+Y,0),U,1)
+8 DO DD^%DT
+9 SET DVBADSCH=Y
+10 SET DVBAHD22="Discharge Date: "_Y
+11 QUIT
End DoDot:1
+12 KILL Y
+13 QUIT
+14 ;
ACT ;sets 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 ;This subroutine will draw the 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 if $DATA(DVBAHD22)
WRITE ?40,DVBAHD22
+13 WRITE !!,?9,"Report",?37,"Selected",?60,"Status"
+14 WRITE !,DVBALN
+15 FOR DVBAX=0:0
SET DVBAX=$ORDER(DVBARPT(DVBAX))
if 'DVBAX
QUIT
DO DRAW1
+16 WRITE !,DVBALN
+17 QUIT
+18 ;
DRAW1 ;rights the reports 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 ?60,$SELECT($PIECE(DVBARPT(DVBAX),U,3)="C":"Completed",$PIECE(DVBARPT(DVBAX),U,3)="P":"Pending",1:"")
+5 QUIT
+6 ;
READ ;reads the user answer
+1 SET DIR(0)="LAO^1:10^K:X[""."" X"
+2 SET DIR("A")="Select Report: "
+3 SET DIR("?",1)="Select a number or range of numbers from 1 to 10 (1,3,5 or 2-4,8). This will"
+4 SET DIR("?",2)="initially mark the report as 'YES'. If the number is selected again then it"
+5 SET DIR("?")="will be changed to 'NO' or vice versa"
+6 DO ^DIR
+7 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+8 IF 'Y
SET DVBAOUT=1
+9 QUIT
+10 ;
ADJ ;This subroutine adjusts the local array
+1 KILL DVBAER
+2 NEW X,A,FLOP
+3 FOR X=1:1:10
SET A=$PIECE(Y,",",X)
if 'A
QUIT
DO DISC
+4 QUIT
+5 ;
DISC ;checks for bad answers
+1 IF $DATA(ADMNUM)
IF $DATA(DVBADSCH)
IF A=1
if '$DATA(DVBAER)
Begin DoDot:1
+2 WRITE *7,!,"Vet already discharged - you cannot request Notice of Discharge."
+3 WRITE !,?30,"<Return> to continue."
+4 READ Z:DTIME
+5 QUIT
End DoDot:1
SET DVBAER=1
QUIT
+6 IF DVBDOC="L"
IF (A=1!(A=2)!(A=3)!(A=9))
if '$DATA(DVBAER)
Begin DoDot:1
+7 WRITE *7,!,"Cannot select 'Notice of Discharge', 'Hospital Summary', 'Certificate (21-day)', or 'Admission Report' for an activity date."
+8 WRITE !,?30,"<Return> to continue."
+9 READ Z:DTIME
+10 QUIT
End DoDot:1
SET DVBAER=1
QUIT
+11 ;
+12 ;If Notice of Discharge selected, check patient's Claim Folder Location.
+13 IF A=1
SET FLOP=0
Begin DoDot:1
+14 NEW CK
SET CK=$$CKCFLOC()
+15 IF CK=1
SET FLOP=1
WRITE *7,!,"The patient has no Claim Folder Location in the Patient File.",!,"Notice of Discharge would not be returned.",!,?30,"<Return> to continue."
READ Z:DTIME
+16 IF CK=2
SET FLOP=1
Begin DoDot:2
+17 WRITE *7,!,"The patient's Claim Folder Location has no Station Number in file #4.",!,"Notice of Discharge would not be returned.",!,"Please check the Claim Folder Location and its entry in file #4.",!,?30,"<Return> to continue."
READ Z:DTIME
End DoDot:2
End DoDot:1
if FLOP
QUIT
+18 ;
+19 ;If 21 Day Certificate selected, check patient's Claim Folder Location.
+20 IF A=3
SET FLOP=0
Begin DoDot:1
+21 NEW CK
SET CK=$$CKCFLOC()
+22 IF CK=1
SET FLOP=1
WRITE *7,!,"The patient has no Claim Folder Location in the Patient File.",!,"21 Day Certificate would not be returned.",!,?30,"<Return> to continue."
READ Z:DTIME
+23 IF CK=2
SET FLOP=1
Begin DoDot:2
+24 WRITE *7,!,"The patient's Claim Folder Location has no Station Number in file #4.",!,"21 Day Certificate would not be returned.",!,"Please check the Claim Folder Location and its entry in file #4.",!,?30,"<Return> to continue."
READ Z:DTIME
End DoDot:2
End DoDot:1
if FLOP
QUIT
+25 DO CHNG
+26 QUIT
+27 ;
CKCFLOC() ;Check if Claim Folder Location or its Station Number is null.
+1 ;If Claim Folder Location and Station Number are not null, CK=0.
+2 ;If Claim Folder Location is null, CK=1.
+3 ;If Station Number is null, CK=2.
+4 NEW CK,ZDFN,ZCFLOC
+5 SET CK=0
+6 SET ZDFN=$PIECE($GET(DFN),U)
IF $GET(ZDFN)=""
SET CK=3
QUIT CK
+7 SET ZCFLOC=$PIECE($GET(^DPT(ZDFN,.31)),U,4)
+8 IF $GET(ZCFLOC)=""
SET CK=1
+9 IF $GET(ZCFLOC)'=""
if $PIECE($GET(^DIC(4,ZCFLOC,99)),U)=""
SET CK=2
+10 QUIT CK
+11 ;
CHNG ;updates the local array
+1 if $PIECE(DVBARPT(A),U,3)["C"
QUIT
+2 SET DVBAOLD=$PIECE(DVBARPT(A),U,2)
+3 SET DVBAOLD=$SELECT(DVBAOLD["Y":"NO",1:"YES")
+4 SET $PIECE(DVBARPT(A),U,2)=DVBAOLD
+5 SET $PIECE(DVBARPT(A),U,3)=$SELECT(DVBAOLD["Y":"P",1:"")
+6 QUIT
+7 ;
FILE ;this subroutine sets the data into the file and asks the last three
+1 ;questions
+2 IF $DATA(DTOUT)
SET DVBANY=1
if '$DATA(DVBAEDT)
DO DEL^DVBAUTL3(DVBAENTR)
QUIT
+3 IF $DATA(DUOUT)
Begin DoDot:1
+4 IF '$DATA(DVBAEDT)
SET DVBANY=1
DO DEL^DVBAUTL3(DVBAENTR)
QUIT
+5 SET DVBANY=$$ANYSEL(DVBAENTR)
+6 IF DVBANY'>0
DO ERR
+7 QUIT
End DoDot:1
QUIT
+8 DO LAST
+9 IF $DATA(Y)
IF '$DATA(DVBAEDT)
Begin DoDot:1
+10 DO DEL^DVBAUTL3(DVBAENTR)
+11 SET DVBANY=1
+12 QUIT
End DoDot:1
QUIT
+13 SET DVBANY=$$ANYSEL(DVBAENTR)
+14 IF 'DVBANY
DO ERR
QUIT
+15 DO STM^DVBCUTL4
+16 DO FILE^DVBAUTL3
+17 SET XRTN=$TEXT(+0)
+18 DO SPM^DVBCUTL4
+19 ;;;D TEST:'$D(DVBAEDT)
+20 QUIT
+21 ;
ERR ;this subroutine will print out an error message when no reports are
+1 ;selected on the 7131.
+2 SET VAR(1,0)="1,0,0,2,0^You have not selected any reports for this 7131 request"
+3 SET VAR(2,0)="0,0,0,1:2,0^or have selected number 4 but not entered any remarks."
+4 DO WR^DVBAUTL4("VAR")
+5 KILL VAR
+6 DO CONTMES^DVBCUTL4
+7 QUIT
+8 ;
ANYSEL(B) ;
+1 ;This subroutine checks to see if any reports were selected on the 7131
+2 ;request.
+3 ;B is the internal entry number in file 396
+4 NEW X,CNT
+5 SET CNT=0
+6 ;checking each report
FOR X=0:0
SET X=$ORDER(DVBARPT(X))
if 'X!(CNT)
QUIT
Begin DoDot:1
+7 IF $PIECE(DVBARPT(X),U,2)="YES"
SET CNT=1
+8 QUIT
End DoDot:1
+9 ;checking opt date range
IF $PIECE(^DVB(396,B,0),U,25)]""
SET CNT=1
+10 ;if no remarks set to zero
IF $PIECE(DVBARPT(4),U,2)="YES"
IF '$ORDER(^DVB(396,B,5,0))
SET CNT=0
+11 QUIT CNT
+12 ;
LAST ;this subroutine will ask the last three questions
+1 SET DIE="^DVB(396,"
SET DA=DVBAENTR
+2 SET DR="18;S X=X;19///^S X=$S($P(^DVB(396,DA,0),U,25)']"""":""@"",$P(^(0),U,26)=""C"":""C"",1:""P"");29Routing Location;.5;23///"_DT_";24///"_DT_";27///"_LOC_";28///"_OPER
+3 DO ^DIE
+4 QUIT
+5 ;
TEST ;tests to see if the user wants this 7131
+1 DO DRAW
+2 WRITE !,*7,"Do you want to file this request"
+3 SET %=1
DO YN^DICN
+4 IF %=2
DO DEL^DVBAUTL3(DVBAENTR)
+5 QUIT
