DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 9/16/03 2:24pm
;;5.3;Registration;**26,31,483,549,570**;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
S XMY("G.DGPM UR ADMISSION")="" ; pass mailgroup
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 V72HR ; visits in last 72 hours
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
N DGX,DGDATA,DGIB
;
S DGIB=$$INSUR^IBBAPI(DFN,"","",.DGDATA,"*") ; Returns Active, Reimbursable Ins. only
S DGX="DGDATA(""IBBAPI"",""INSUR"")" M DGIBINS=@DGX
F I=0:0 S I=$O(DGIBINS(I)) Q:'I D ACT
;
I $D(DGPMUR(10)) S DGPMLAST=DGPMBLN
Q
;
ACT ;is insurance active? If so, set in DGPMBLN array
I DGIBINS(I,11)<+DGPMA,DGIBINS(I,11)]"" Q ;insurance expired before admission
I DGIBINS(I,10)>+DGPMA Q ;insurance effective after admission
Q:'+DGIBINS(I,1)
; get insurance company information
S DGPMBL="Insurance Co. : "_$P(DGIBINS(I,1),"^",2) D SETLN
S DGTMP=$P(DGIBINS(I,8),U,2)
I DGTMP']"" S DGTMP=$S($G(DGIBNS(I,18))]"":DGIBINS(I,18),1:"")
I DGTMP']"" S DGTMP=""
I DGTMP]"" S DGPMBL="Group : "_DGTMP D SETLN
S DGPMBL="Policy Holder : "_DGIBINS(I,13) D SETLN
S DGPMBL="Subscriber ID : "_DGIBINS(I,14) D SETLN
S DGPMBL="Ins. Co Phone# : "_$S(DGIBINS(I,6)]"":DGIBINS(I,6),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
V72HR ; GET INFORMATION FROM VISITS FOR THE LAST 72 HOURS
NEW X,X1,X2,IDEN,ID,LOCN,HSPN
S X1=+DGPMA,X2=-3
D C^%DTC
S X=X-.0001
GVTIME ; LOOP THROUGH "B" INDEX OF ^AUPNVSIT FILE
S X=$O(^AUPNVSIT("B",X))
I X="" Q
I X'<+DGPMA Q
S IDEN=""
GVID ; CHECK FOR CORRECT PATIENT
S IDEN=$O(^AUPNVSIT("B",X,IDEN))
I IDEN="" G GVTIME
I +$P($G(^AUPNVSIT(IDEN,0)),"^",5)'=+DFN G GVID
S LOCN=$P(^AUPNVSIT(IDEN,0),"^",22)
; DG/549
I $G(LOCN)>0 S HSPN=$P($G(^SC(LOCN,0)),"^",1)
E S HSPN="Unknown location" I $P($G(^AUPNVSIT(IDEN,0)),"^",7)="E" S HSPN=HSPN_"-Event(Historical)"
;
S Y=+X X ^DD("DD")
S DGPMBL="Previous Visit : "_HSPN_" "_Y
D SETLN
G GVID
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[HDGPMVBUR 3555 printed Sep 23, 2025@20:26:18 Page 2
DGPMVBUR ;ALB/MIR - UR ADMISSION BULLETIN FOR MCCR ; 9/16/03 2:24pm
+1 ;;5.3;Registration;**26,31,483,549,570**;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 ; pass mailgroup
SET XMY("G.DGPM UR ADMISSION")=""
+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 ; visits in last 72 hours
SET DGPMBLN=DGPMLAST
DO V72HR
+15 ;SC disabilities
DO DIS
+16 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 NEW DGX,DGDATA,DGIB
+4 ;
+5 ; Returns Active, Reimbursable Ins. only
SET DGIB=$$INSUR^IBBAPI(DFN,"","",.DGDATA,"*")
+6 SET DGX="DGDATA(""IBBAPI"",""INSUR"")"
MERGE DGIBINS=@DGX
+7 FOR I=0:0
SET I=$ORDER(DGIBINS(I))
if 'I
QUIT
DO ACT
+8 ;
+9 IF $DATA(DGPMUR(10))
SET DGPMLAST=DGPMBLN
+10 QUIT
+11 ;
ACT ;is insurance active? If so, set in DGPMBLN array
+1 ;insurance expired before admission
IF DGIBINS(I,11)<+DGPMA
IF DGIBINS(I,11)]""
QUIT
+2 ;insurance effective after admission
IF DGIBINS(I,10)>+DGPMA
QUIT
+3 if '+DGIBINS(I,1)
QUIT
+4 ; get insurance company information
+5 SET DGPMBL="Insurance Co. : "_$PIECE(DGIBINS(I,1),"^",2)
DO SETLN
+6 SET DGTMP=$PIECE(DGIBINS(I,8),U,2)
+7 IF DGTMP']""
SET DGTMP=$SELECT($GET(DGIBNS(I,18))]"":DGIBINS(I,18),1:"")
+8 IF DGTMP']""
SET DGTMP=""
+9 IF DGTMP]""
SET DGPMBL="Group : "_DGTMP
DO SETLN
+10 SET DGPMBL="Policy Holder : "_DGIBINS(I,13)
DO SETLN
+11 SET DGPMBL="Subscriber ID : "_DGIBINS(I,14)
DO SETLN
+12 SET DGPMBL="Ins. Co Phone# : "_$SELECT(DGIBINS(I,6)]"":DGIBINS(I,6),1:"UNKNOWN")
DO SETLN
+13 SET DGPMBL=" "
DO SETLN
+14 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
V72HR ; GET INFORMATION FROM VISITS FOR THE LAST 72 HOURS
+1 NEW X,X1,X2,IDEN,ID,LOCN,HSPN
+2 SET X1=+DGPMA
SET X2=-3
+3 DO C^%DTC
+4 SET X=X-.0001
GVTIME ; LOOP THROUGH "B" INDEX OF ^AUPNVSIT FILE
+1 SET X=$ORDER(^AUPNVSIT("B",X))
+2 IF X=""
QUIT
+3 IF X'<+DGPMA
QUIT
+4 SET IDEN=""
GVID ; CHECK FOR CORRECT PATIENT
+1 SET IDEN=$ORDER(^AUPNVSIT("B",X,IDEN))
+2 IF IDEN=""
GOTO GVTIME
+3 IF +$PIECE($GET(^AUPNVSIT(IDEN,0)),"^",5)'=+DFN
GOTO GVID
+4 SET LOCN=$PIECE(^AUPNVSIT(IDEN,0),"^",22)
+5 ; DG/549
+6 IF $GET(LOCN)>0
SET HSPN=$PIECE($GET(^SC(LOCN,0)),"^",1)
+7 IF '$TEST
SET HSPN="Unknown location"
IF $PIECE($GET(^AUPNVSIT(IDEN,0)),"^",7)="E"
SET HSPN=HSPN_"-Event(Historical)"
+8 ;
+9 SET Y=+X
XECUTE ^DD("DD")
+10 SET DGPMBL="Previous Visit : "_HSPN_" "_Y
+11 DO SETLN
+12 GOTO GVID
+13 QUIT
SETLN ;--set line in xmtext array
+1 SET DGPMBLN=DGPMBLN+1
+2 SET DGPMUR(DGPMBLN)=DGPMBL
+3 QUIT
