IB20PT81 ;ALB/CPM - EXPORT ROUTINE 'DGBLRV' ; 24-FEB-94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
DGBLRV ;ALB/BOK - PATIENT ADMISSION FORM/BILL REVIEW ; 18 SEP 86 11:00
;;5.3;Registration;**26**;Aug 13, 1993
;
D LO^DGUTL K ^UTILITY($J)
START S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G QUIT:Y'>0 S DFN=+Y I '$D(^DGPM("ATID1",DFN)) W !,"No admissions on file, will check scheduled admissions",! G SCHAD
S DIC("S")="I $P(^(0),U,2)=1" D EN^DGPMUTL K DIC I Y'>0 W !,"Since an admission was not chosen, scheduled admissions for this patient will be checked",! G SCHAD
S DGPMDA=+Y G IO
SCHAD I '$D(^DGS(41.1,"B",DFN)) W !,"No scheduled admissions on file" G QUIT
S DGPMDA=0
IO K DIS(0) S DGPGM="RET^DGBLRV",DGVAR="DFN^DGPMDA" W !!,"This report requires 132 column output",! D ZIS^DGUTQ G QUIT:POP U IO S X=132 X ^%ZOSF("RM")
RET S:'$D(DGPMDA) DGPMDA=0 K DGADT,DGADX,DGINAD,DGSDT,DGSDX,I S DGINFO=^DPT(DFN,0) D PID^VADPT6
I DGPMDA S DGI=$S($D(^DGPM(DGPMDA,0)):^(0),1:"") Q:DGI']"" S Y=$P(DGI,"^",1) D D^DIQ S DGADT=Y,DGADX=$P(DGI,"^",10),DGWD=$P(DGI,"^",6) G INS
S DGI=$O(^DGS(41.1,"B",DFN,0)),DGI=^DGS(41.1,DGI,0),DGSDT=$P(DGI,U,2) S Y=DGSDT D D^DIQ S DGSDT=Y,DGSDX=$P(DGI,U,4),DGWD=$P(DGI,U,8)
;
INS ; -- new insurance logic
N DGIBINS,DGIBDT
S DGIBDT=$S($D(DGPMDA):+$G(^DGPM(DGPMDA,0)),$G(DGSDT):DGSDT,1:DT)
D ALL^IBCNS1(DFN,"DGIBINS",2,DGIBDT)
S P=1
I $G(DGIBINS(0)) F I=0:0 S I=$O(DGIBINS(I)) Q:'I D
.S DGINS=$G(DGIBINS(I,0)) I $P(DGINS,U,4)>DT!($P(DGINS,U,4)="") K DGINAD D:DGI ADDR S I(P)=+DGINS_U_$P(DGINS,U,2)_U_$P(DGINS,U,3)_U_$P(DGINS,U,5)_U_$S($D(DGINAD):DGINAD,1:"NO ADDRESS ON FILE"),P=P+1
;
PRT K DIC S DIC(0)="M",X="DGBILLREVIEW",DIC="^DIC(47," D ^DIC G QUIT:Y'>0 S DGY=+Y I '$D(DIS(0)) I $$FIRST^DGUTL G Q
S P=0 F DGLN=0:0 S DGLN=$O(^DIC(47,+DGY,1,DGLN)) Q:'DGLN S J=^(DGLN,0),X1="" W ! F K=1:1 W $E($P(J,"{}",K),$S(K=1:1,X1']"":1,1:$L(X)+1),999) S X1=$P(J,"{",K+1),P=$S(DGLN<9:1,DGLN<14:2,1:3) Q:X1']"" D CKLN
Q W ! Q:$D(DIS(0)) I '$D(DGOPT) D CLOSE^DGUTQ
QUIT D ENDREP^DGUTL I '$D(DGPMA) K DFN,DGPMDA
K DGADT,DGADX,DGI,DGIMULT,DGINAD,DGINFO,DGINS,DGLN,DGPGM,DGSDT,DGSDX,DGVAR,DGWD,DGY,DIC,I,J,K,P,X,X1,L,VA,Y,POP Q
Q
;
CKLN S L=$S(DGLN>9&(DGLN<14):(DGLN-5),DGLN>14&(DGLN<19):(DGLN-10),1:DGLN)_K D @L Q
ADDR S DGIMULT=$S($D(^DIC(36,+DGINS,.11)):^(.11),1:"") Q:DGIMULT=""
S DGINAD=$S($P(DGIMULT,U,1)]"":$P(DGIMULT,U,1)_", ",1:"")_$S($P(DGIMULT,U,2)]"":$P(DGIMULT,U,2)_", ",1:"")_$S($P(DGIMULT,U,3)]"":$P(DGIMULT,U,3)_", ",1:"")_$S($P(DGIMULT,U,4)]"":$P(DGIMULT,U,4)_", ",1:"")
S DGINAD=DGINAD_$S('$D(^DIC(5,+$P(DGIMULT,U,5),0)):"",$P(^(0),U,1)]"":$P(^(0),U,1)_", ",1:"")_$S($L($P(DGIMULT,U,6))>5:$E($P(DGIMULT,U,6),1,5)_"-"_$E($P(DGIMULT,U,6),6,9),1:$P(DGIMULT,U,6)) Q
21 S Y=DT D DT^DIQ Q
31 W $P(DGINFO,U,1) Q
32 W VA("PID") Q
51 W $S('$D(I(P)):"",$D(^DIC(36,+I(P),0)):$P(^(0),U),1:"") Q
61 W $S($D(I(P)):$P(I(P),U,5),1:"") Q
71 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",K),.13)):$P(^(.13),"^",1),1:"") Q
72 W $S($D(I(P)):$P(I(P),U,2),1:"") Q
73 W $S($D(I(P)):$P(I(P),U,3),1:"") Q
81 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",1),.13)):$P(^(.13),"^",3),1:"") Q
82 W $S('$D(I(P)):"",$D(^DIC(36,$P(I(P),"^",1),.13)):$P(^(.13),"^",2),1:"") Q
201 W $S($D(DGADX):DGADX,$D(DGSDX):DGSDX,1:"") Q
202 S X=$S(DGWD:DGWD,1:"-") W $S($D(^DIC(42,X,0)):$P(^(0),U,1),1:"") Q
211 W $S($D(DGSDT):DGSDT,1:"") Q
212 W $S($D(DGADT):DGADT,1:"") Q
;
EN1 S DIC="^DGPM(",BY="@.01",L=0,FLDS="[DGPMBLRV]",DHD="@"
S DIS(0)="S DFN=$P(^DGPM(D0,0),U,3) I $P(^(0),""^"",2)=1,$D(^DPT(DFN,""VET"")),($P(^(""VET""),""^"",1)=""Y""),$O(^DPT(DFN,.312,0))"
D EN1^DIP,QUIT K BY,DHD,DIC,DIS,FLDS,I Q
;
CK ;check logic to see if 3rd party review is asked
;***if this logic is altered, also change line EN1+1 in DIS(0)***
I $S('$O(^DPT(DFN,.312,0)):1,'$D(^DPT(DFN,"VET")):1,^("VET")'="Y":1,1:0) Q
ASK ;print TPR?
W !,"PRINT THIRD PARTY REVIEW" S %=$S($D(DGDEF):DGDEF,1:2) D YN^DICN
I %=2!(%<0) Q
I '% W !!,"CHOOSE FROM",!?4,"YES - If you wish to print Third Party Review Sheet",!?4,"NO - If you don't want to print Third Party Review Sheet",! G ASK
Q:$D(DGNOQ) ;quit if from 10/10 w/out registration
K DGPTPR S DGPGM="RET^DGBLRV",DGVAR="DFN"_$S($D(DGPMDA):"^DGPMDA",1:"") K DIS D ZIS^DGUTQ I 'POP U IO D RET^DGBLRV
K DGPGM,DGVAR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT81 4307 printed Dec 13, 2024@02:05:27 Page 2
IB20PT81 ;ALB/CPM - EXPORT ROUTINE 'DGBLRV' ; 24-FEB-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
DGBLRV ;ALB/BOK - PATIENT ADMISSION FORM/BILL REVIEW ; 18 SEP 86 11:00
+1 ;;5.3;Registration;**26**;Aug 13, 1993
+2 ;
+3 DO LO^DGUTL
KILL ^UTILITY($JOB)
START SET DIC="^DPT("
SET DIC(0)="AEQMZ"
DO ^DIC
if Y'>0
GOTO QUIT
SET DFN=+Y
IF '$DATA(^DGPM("ATID1",DFN))
WRITE !,"No admissions on file, will check scheduled admissions",!
GOTO SCHAD
+1 SET DIC("S")="I $P(^(0),U,2)=1"
DO EN^DGPMUTL
KILL DIC
IF Y'>0
WRITE !,"Since an admission was not chosen, scheduled admissions for this patient will be checked",!
GOTO SCHAD
+2 SET DGPMDA=+Y
GOTO IO
SCHAD IF '$DATA(^DGS(41.1,"B",DFN))
WRITE !,"No scheduled admissions on file"
GOTO QUIT
+1 SET DGPMDA=0
IO KILL DIS(0)
SET DGPGM="RET^DGBLRV"
SET DGVAR="DFN^DGPMDA"
WRITE !!,"This report requires 132 column output",!
DO ZIS^DGUTQ
if POP
GOTO QUIT
USE IO
SET X=132
XECUTE ^%ZOSF("RM")
RET if '$DATA(DGPMDA)
SET DGPMDA=0
KILL DGADT,DGADX,DGINAD,DGSDT,DGSDX,I
SET DGINFO=^DPT(DFN,0)
DO PID^VADPT6
+1 IF DGPMDA
SET DGI=$SELECT($DATA(^DGPM(DGPMDA,0)):^(0),1:"")
if DGI']""
QUIT
SET Y=$PIECE(DGI,"^",1)
DO D^DIQ
SET DGADT=Y
SET DGADX=$PIECE(DGI,"^",10)
SET DGWD=$PIECE(DGI,"^",6)
GOTO INS
+2 SET DGI=$ORDER(^DGS(41.1,"B",DFN,0))
SET DGI=^DGS(41.1,DGI,0)
SET DGSDT=$PIECE(DGI,U,2)
SET Y=DGSDT
DO D^DIQ
SET DGSDT=Y
SET DGSDX=$PIECE(DGI,U,4)
SET DGWD=$PIECE(DGI,U,8)
+3 ;
INS ; -- new insurance logic
+1 NEW DGIBINS,DGIBDT
+2 SET DGIBDT=$SELECT($DATA(DGPMDA):+$GET(^DGPM(DGPMDA,0)),$GET(DGSDT):DGSDT,1:DT)
+3 DO ALL^IBCNS1(DFN,"DGIBINS",2,DGIBDT)
+4 SET P=1
+5 IF $GET(DGIBINS(0))
FOR I=0:0
SET I=$ORDER(DGIBINS(I))
if 'I
QUIT
Begin DoDot:1
+6 SET DGINS=$GET(DGIBINS(I,0))
IF $PIECE(DGINS,U,4)>DT!($PIECE(DGINS,U,4)="")
KILL DGINAD
if DGI
DO ADDR
SET I(P)=+DGINS_U_$PIECE(DGINS,U,2)_U_$PIECE(DGINS,U,3)_U_$PIECE(DGINS,U,5)_U_$SELECT($DATA(DGINAD):DGINAD,1:"NO ADDRESS ON FILE")
SET P=P+1
End DoDot:1
+7 ;
PRT KILL DIC
SET DIC(0)="M"
SET X="DGBILLREVIEW"
SET DIC="^DIC(47,"
DO ^DIC
if Y'>0
GOTO QUIT
SET DGY=+Y
IF '$DATA(DIS(0))
IF $$FIRST^DGUTL
GOTO Q
+1 SET P=0
FOR DGLN=0:0
SET DGLN=$ORDER(^DIC(47,+DGY,1,DGLN))
if 'DGLN
QUIT
SET J=^(DGLN,0)
SET X1=""
WRITE !
FOR K=1:1
WRITE $EXTRACT($PIECE(J,"{}",K),$SELECT(K=1:1,X1']"":1,1:$LENGTH(X)+1),999)
SET X1=$PIECE(J,"{",K+1)
SET P=$SELECT(DGLN<9:1,DGLN<14:2,1:3)
if X1']""
QUIT
DO CKLN
Q WRITE !
if $DATA(DIS(0))
QUIT
IF '$DATA(DGOPT)
DO CLOSE^DGUTQ
QUIT DO ENDREP^DGUTL
IF '$DATA(DGPMA)
KILL DFN,DGPMDA
+1 KILL DGADT,DGADX,DGI,DGIMULT,DGINAD,DGINFO,DGINS,DGLN,DGPGM,DGSDT,DGSDX,DGVAR,DGWD,DGY,DIC,I,J,K,P,X,X1,L,VA,Y,POP
QUIT
+2 QUIT
+3 ;
CKLN SET L=$SELECT(DGLN>9&(DGLN<14):(DGLN-5),DGLN>14&(DGLN<19):(DGLN-10),1:DGLN)_K
DO @L
QUIT
ADDR SET DGIMULT=$SELECT($DATA(^DIC(36,+DGINS,.11)):^(.11),1:"")
if DGIMULT=""
QUIT
+1 SET DGINAD=$SELECT($PIECE(DGIMULT,U,1)]"":$PIECE(DGIMULT,U,1)_", ",1:"")_$SELECT($PIECE(DGIMULT,U,2)]"":$PIECE(DGIMULT,U,2)_", ",1:"")_$SELECT($PIECE(DGIMULT,U,3)]"":$PIECE(DGIMULT,U,3)_", ",1:"")_$SELECT(...
... $PIECE(DGIMULT,U,4)]"":$PIECE(DGIMULT,U,4)_", ",1:"")
+2 SET DGINAD=DGINAD_$SELECT('$DATA(^DIC(5,+$PIECE(DGIMULT,U,5),0)):"",$PIECE(^(0),U,1)]"":$PIECE(^(0),U,1)_", ",1:"")_$SELECT($LENGTH($PIECE(DGIMULT,U,6))>5:$EXTRACT($PIECE(DGIMULT,U,6),1,5)_"-"_$EXTRACT($PIECE(DGIMULT,U,6),6,9),1:$PIECE(DGIMULT,
U,6))
QUIT
21 SET Y=DT
DO DT^DIQ
QUIT
31 WRITE $PIECE(DGINFO,U,1)
QUIT
32 WRITE VA("PID")
QUIT
51 WRITE $SELECT('$DATA(I(P)):"",$DATA(^DIC(36,+I(P),0)):$PIECE(^(0),U),1:"")
QUIT
61 WRITE $SELECT($DATA(I(P)):$PIECE(I(P),U,5),1:"")
QUIT
71 WRITE $SELECT('$DATA(I(P)):"",$DATA(^DIC(36,$PIECE(I(P),"^",K),.13)):$PIECE(^(.13),"^",1),1:"")
QUIT
72 WRITE $SELECT($DATA(I(P)):$PIECE(I(P),U,2),1:"")
QUIT
73 WRITE $SELECT($DATA(I(P)):$PIECE(I(P),U,3),1:"")
QUIT
81 WRITE $SELECT('$DATA(I(P)):"",$DATA(^DIC(36,$PIECE(I(P),"^",1),.13)):$PIECE(^(.13),"^",3),1:"")
QUIT
82 WRITE $SELECT('$DATA(I(P)):"",$DATA(^DIC(36,$PIECE(I(P),"^",1),.13)):$PIECE(^(.13),"^",2),1:"")
QUIT
201 WRITE $SELECT($DATA(DGADX):DGADX,$DATA(DGSDX):DGSDX,1:"")
QUIT
202 SET X=$SELECT(DGWD:DGWD,1:"-")
WRITE $SELECT($DATA(^DIC(42,X,0)):$PIECE(^(0),U,1),1:"")
QUIT
211 WRITE $SELECT($DATA(DGSDT):DGSDT,1:"")
QUIT
212 WRITE $SELECT($DATA(DGADT):DGADT,1:"")
QUIT
+1 ;
EN1 SET DIC="^DGPM("
SET BY="@.01"
SET L=0
SET FLDS="[DGPMBLRV]"
SET DHD="@"
+1 SET DIS(0)="S DFN=$P(^DGPM(D0,0),U,3) I $P(^(0),""^"",2)=1,$D(^DPT(DFN,""VET"")),($P(^(""VET""),""^"",1)=""Y""),$O(^DPT(DFN,.312,0))"
+2 DO EN1^DIP
DO QUIT
KILL BY,DHD,DIC,DIS,FLDS,I
QUIT
+3 ;
CK ;check logic to see if 3rd party review is asked
+1 ;***if this logic is altered, also change line EN1+1 in DIS(0)***
+2 IF $SELECT('$ORDER(^DPT(DFN,.312,0)):1,'$DATA(^DPT(DFN,"VET")):1,^("VET")'="Y":1,1:0)
QUIT
ASK ;print TPR?
+1 WRITE !,"PRINT THIRD PARTY REVIEW"
SET %=$SELECT($DATA(DGDEF):DGDEF,1:2)
DO YN^DICN
+2 IF %=2!(%<0)
QUIT
+3 IF '%
WRITE !!,"CHOOSE FROM",!?4,"YES - If you wish to print Third Party Review Sheet",!?4,"NO - If you don't want to print Third Party Review Sheet",!
GOTO ASK
+4 ;quit if from 10/10 w/out registration
if $DATA(DGNOQ)
QUIT
+5 KILL DGPTPR
SET DGPGM="RET^DGBLRV"
SET DGVAR="DFN"_$SELECT($DATA(DGPMDA):"^DGPMDA",1:"")
KILL DIS
DO ZIS^DGUTQ
IF 'POP
USE IO
DO RET^DGBLRV
+6 KILL DGPGM,DGVAR
QUIT
