IB20PT8B ;ALB/CPM - EXPORT ROUTINE 'DGPMVBUR' ; 24-FEB-94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 13 JUL 91
;;5.3;Registration;**26**;Aug 13, 1993
;
UR ;UR bulletin
K DGPMUR
D INS I '$D(DGPMUR(10)) D URQ Q
S DGPMX=$O(^XMB(3.8,"B","DGPM UR ADMISSION",0)) I '$O(^XMB(3.8,+DGPMX,1,0)) K DGPMX D URQ Q ; if no mailgroup members, quit
S XMSUB="UR ADMISSION BULLETIN",XMTEXT="DGPMUR(",DGPMBLN=0
F I=0:0 S I=$O(^XMB(3.8,+DGPMX,1,I)) Q:'I I $D(^(I,0)) S XMY(+^(0))=""
D PID^VADPT6 S DGPMBL="Admission for : "_$P(^DPT(DFN,0),"^",1)_" "_VA("PID") D SETLN
S Y=+DGPMA X ^DD("DD") S DGPMBL="Date/Time : "_Y D SETLN
S DGPMBL="Type of Admit : "_$S($D(^DG(405.1,+$P(DGPMA,"^",4),0)):$P(^(0),"^",1),1:"") D SETLN
S DGPMBL=" " D SETLN
S DGPMBL="Ward Location : "_$S($D(^DIC(42,+$P(DGPMA,"^",6),0)):$P(^(0),"^",1),1:"UNKNOWN") D SETLN
S DGPMBL="Room-Bed : "_$S($D(^DG(405.4,+$P(DGPMA,"^",7),0)):$P(^(0),"^",1),1:"UNKNOWN") D SETLN
S DGPMBL="Admitting DX : "_$P(DGPMA,"^",10) D SETLN
S DGPMBL=" " D SETLN
S DGPMBLN=DGPMLAST D DIS ;SC disabilities
D ^XMD
URQ K DGPMBL,DGPMBLN,DGPMLAST,DGPMUR,DGTMP,XMY,XMSUB,XMTEXT
K %,%Y,DGPMOB,DGPMOW,DGPMX,I,X,X1,X2,Y,DGIBINS
Q
;
INS ;get insurance effective at time of admission, start at DGPMBLN=10
S DGPMBLN=9
K DGIBINS
D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S X=DGIBINS(I,0) D ACT
I $D(DGPMUR(10)) S DGPMLAST=DGPMBLN
Q
;
ACT ;is insurance active? If so, set in DGPMBLN array
I $P(X,"^",4)<+DGPMA,$P(X,"^",4) Q ;insurance expired before admission
I $P(X,"^",8)>+DGPMA Q ;insurance effective after admission
Q:'$D(^DIC(36,+X,0)) S X1=^(0),X2=$S($D(^(.13)):^(.13),1:"") ;get insurance company information
I $P(X1,"^",5)!($P(X1,"^",2)="N") Q ;insurance company is inactive or doesn't reimburse
S DGPMBL="Insurance Co. : "_$P(X1,"^",1) D SETLN
S DGTMP=$S(($P(X,"^",15)]""):$P(X,"^",15),1:$P(X,"^",3))
I DGTMP]"" S DGPMBL="Group : "_DGTMP D SETLN
S DGPMBL="Policy Holder : "_$P(X,"^",17) D SETLN
S DGPMBL="Subscriber ID : "_$P(X,"^",2) D SETLN
S DGPMBL="Ins. Co Phone# : "_$S($P(X2,"^",2)]"":$P(X2,"^",2),$P(X2,"^",1)]"":$P(X2,"^",1),1:"UNKNOWN") D SETLN
S DGPMBL=" " D SETLN
Q
DIS ;rated disabilities
I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),"^",1)'="Y":1,1:"") Q ;not service connected...
I $S('$D(^DPT(DFN,"VET")):1,$P(^("VET"),"^",1)'="Y":1,1:0),$S('$D(^DG(391,+$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:""),0)):1,$P(^(0),"^",2):0,1:1) Q
;X=0 node, X1=already one SC disability?
S X1=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I I $D(^(I,0)) S X=^(0) I $P(X,"^",3)&$D(^DIC(31,+X,0)) S DGPMBL=$S('X1:"SC Disabilities: ",1:" ")_$P(^(0),"^",1)_" ("_+$P(X,"^",2)_"%)" S X1=1 D SETLN
Q
SETLN ; -- set line in xmtext array
S DGPMBLN=DGPMBLN+1
S DGPMUR(DGPMBLN)=DGPMBL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT8B 2907 printed Dec 13, 2024@02:05:37 Page 2
IB20PT8B ;ALB/CPM - EXPORT ROUTINE 'DGPMVBUR' ; 24-FEB-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 13 JUL 91
+1 ;;5.3;Registration;**26**;Aug 13, 1993
+2 ;
UR ;UR bulletin
+1 KILL DGPMUR
+2 DO INS
IF '$DATA(DGPMUR(10))
DO URQ
QUIT
+3 ; if no mailgroup members, quit
SET DGPMX=$ORDER(^XMB(3.8,"B","DGPM UR ADMISSION",0))
IF '$ORDER(^XMB(3.8,+DGPMX,1,0))
KILL DGPMX
DO URQ
QUIT
+4 SET XMSUB="UR ADMISSION BULLETIN"
SET XMTEXT="DGPMUR("
SET DGPMBLN=0
+5 FOR I=0:0
SET I=$ORDER(^XMB(3.8,+DGPMX,1,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET XMY(+^(0))=""
+6 DO PID^VADPT6
SET DGPMBL="Admission for : "_$PIECE(^DPT(DFN,0),"^",1)_" "_VA("PID")
DO SETLN
+7 SET Y=+DGPMA
XECUTE ^DD("DD")
SET DGPMBL="Date/Time : "_Y
DO SETLN
+8 SET DGPMBL="Type of Admit : "_$SELECT($DATA(^DG(405.1,+$PIECE(DGPMA,"^",4),0)):$PIECE(^(0),"^",1),1:"")
DO SETLN
+9 SET DGPMBL=" "
DO SETLN
+10 SET DGPMBL="Ward Location : "_$SELECT($DATA(^DIC(42,+$PIECE(DGPMA,"^",6),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
DO SETLN
+11 SET DGPMBL="Room-Bed : "_$SELECT($DATA(^DG(405.4,+$PIECE(DGPMA,"^",7),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
DO SETLN
+12 SET DGPMBL="Admitting DX : "_$PIECE(DGPMA,"^",10)
DO SETLN
+13 SET DGPMBL=" "
DO SETLN
+14 ;SC disabilities
SET DGPMBLN=DGPMLAST
DO DIS
+15 DO ^XMD
URQ KILL DGPMBL,DGPMBLN,DGPMLAST,DGPMUR,DGTMP,XMY,XMSUB,XMTEXT
+1 KILL %,%Y,DGPMOB,DGPMOW,DGPMX,I,X,X1,X2,Y,DGIBINS
+2 QUIT
+3 ;
INS ;get insurance effective at time of admission, start at DGPMBLN=10
+1 SET DGPMBLN=9
+2 KILL DGIBINS
+3 DO ALL^IBCNS1(DFN,"DGIBINS")
FOR I=0:0
SET I=$ORDER(DGIBINS(I))
if 'I
QUIT
SET X=DGIBINS(I,0)
DO ACT
+4 IF $DATA(DGPMUR(10))
SET DGPMLAST=DGPMBLN
+5 QUIT
+6 ;
ACT ;is insurance active? If so, set in DGPMBLN array
+1 ;insurance expired before admission
IF $PIECE(X,"^",4)<+DGPMA
IF $PIECE(X,"^",4)
QUIT
+2 ;insurance effective after admission
IF $PIECE(X,"^",8)>+DGPMA
QUIT
+3 ;get insurance company information
if '$DATA(^DIC(36,+X,0))
QUIT
SET X1=^(0)
SET X2=$SELECT($DATA(^(.13)):^(.13),1:"")
+4 ;insurance company is inactive or doesn't reimburse
IF $PIECE(X1,"^",5)!($PIECE(X1,"^",2)="N")
QUIT
+5 SET DGPMBL="Insurance Co. : "_$PIECE(X1,"^",1)
DO SETLN
+6 SET DGTMP=$SELECT(($PIECE(X,"^",15)]""):$PIECE(X,"^",15),1:$PIECE(X,"^",3))
+7 IF DGTMP]""
SET DGPMBL="Group : "_DGTMP
DO SETLN
+8 SET DGPMBL="Policy Holder : "_$PIECE(X,"^",17)
DO SETLN
+9 SET DGPMBL="Subscriber ID : "_$PIECE(X,"^",2)
DO SETLN
+10 SET DGPMBL="Ins. Co Phone# : "_$SELECT($PIECE(X2,"^",2)]"":$PIECE(X2,"^",2),$PIECE(X2,"^",1)]"":$PIECE(X2,"^",1),1:"UNKNOWN")
DO SETLN
+11 SET DGPMBL=" "
DO SETLN
+12 QUIT
DIS ;rated disabilities
+1 ;not service connected...
IF $SELECT('$DATA(^DPT(DFN,.3)):1,$PIECE(^(.3),"^",1)'="Y":1,1:"")
QUIT
+2 IF $SELECT('$DATA(^DPT(DFN,"VET")):1,$PIECE(^("VET"),"^",1)'="Y":1,1:0)
IF $SELECT('$DATA(^DG(391,+$SELECT($DATA(^DPT(DFN,"TYPE")):^("TYPE"),1:""),0)):1,$PIECE(^(0),"^",2):0,1:1)
QUIT
+3 ;X=0 node, X1=already one SC disability?
+4 SET X1=0
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET X=^(0)
IF $PIECE(X,"^",3)&$DATA(^DIC(31,+X,0))
SET DGPMBL=$SELECT('X1:"SC Disabilities: ",1:" ")_$PIECE(^(0),"^",1)_" ("_+$PIECE(X,"^",2)_"%)"
SET X1=1
DO SETLN
+5 QUIT
SETLN ; -- set line in xmtext array
+1 SET DGPMBLN=DGPMBLN+1
+2 SET DGPMUR(DGPMBLN)=DGPMBL
+3 QUIT
