IB20PT8B.m

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 ---IB20PT8B   2907     printed  Feb 18, 2025@23:32:02                                                                                                                                                                                                    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