DGRP15 ;ALB/MTC - TRICARE DEMOGRAPHIC DATA ;03/05/2004
;;5.3;Registration;**114,239,568,867**;Aug 13, 1993;Build 59
;
EN ;
N X,Y,DGSA,SPFLAG,NEWBAR,LINE,NN,CNT
1 S DGSA=""
;-- get sponsor info
S SPFLAG=0
D GET
;-- draw header
S (DGRPS,DGRPW)=15 D H^DGRPU
;--
S Z=1 D WW^DGRPV W " Sponsor Information:"
I DGSA D
. S Y=1,X=0 F S X=$O(DGSA(X)) Q:'X D DISPON(X) S Y=Y+1 Q:Y>2
E W:'SPFLAG !,!,"No Sponsor Information available."
I SPFLAG W !?4,"Sponsored Newborn:" D
. S NN="",CNT=0 F S NN=$O(NEWBAR(NN)) Q:(NN="")!(CNT=2) D
.. S SPN=""
.. F S SPN=$O(NEWBAR(NN,SPN)) Q:(SPN="")!(CNT=2) D
... S CNT=CNT+1
... W !?7,"NAME : ",$P(NEWBAR(NN,SPN),"^")
... W !?8,"DOB : " S Y=$P(NEWBAR(NN,SPN),"^",2) X ^DD("DD") W Y
... W !?8,"SSN : ",$P(NEWBAR(NN,SPN),"^",3)
... W !?6,"Effective Date : " S Y=$P(NEWBAR(NN,SPN),"^",4) X ^DD("DD") W Y
... W ?38,"Expiration Date : " S Y=$P(NEWBAR(NN,SPN),"^",5) X ^DD("DD") W Y
... W !
I SPFLAG>2 W "Sponsor has ",SPFLAG," sponsored newborn children."
W !
2 ;-- Primary Care
;
;-- get primary care data
D
.N CT,GBL S GBL="GBL"
.D TDATA^DGSDUTL(DFN,.CT,DT)
.I CT>12 S GBL(11,0)="" D
..S GBL(12,0)=" *** Additional assignment information exists ***"
.S CT=0 F S CT=$O(GBL(CT)) Q:'CT!(CT>12) W !,GBL(CT,0)
.Q
;
;-- goto main registration screen processing routine
G ^DGRPP
;
Q
;
DISPON(SPON) ;-- This function will display the Sponsor designated by
; SPON.^
;
W !,!," Name : " S Z=$P(DGSA(SPON,"SPON"),U),Z1=30 D WW1^DGRPV
W ?40,"Military Status : ",$P(DGSA(SPON,"SPON"),U,4)
W !," DOB : " S Z=$P(DGSA(SPON,"SPON"),U,2),Z1=28 D WW1^DGRPV
W ?35,"Branch of Service : ",$P(DGSA(SPON,"SPON"),U,5)
W !," SSN : " S Z=$P(DGSA(SPON,"SPON"),U,3),Z1=15 D WW1^DGRPV
W ?52,"Rank : ",$P(DGSA(SPON,"SPON"),U,6)
W !," Prefix : " S Z=$P(DGSA(SPON,"REL"),U,2),Z1=12 D WW1^DGRPV
W ?52,"Type : ",$P(DGSA(SPON,"REL"),U,3)
S Y=$P(DGSA(SPON,"REL"),U,4) X ^DD("DD")
W !," Effective Date : ",Y
S Y=$P(DGSA(SPON,"REL"),U,5) X ^DD("DD")
W ?35,"Expiration Date: ",Y
Q
;
GET ;-- get sponsor information and populate the DGSA array.
N NEWB,SPON1,X,SPN,HDT,LINE,N,AA,BDOB
D GET^IBCNSU4(DFN,.DGSA)
; -- Find the Newborn sponsored info
; -- look at all of the patient's sponsor relationships
S X=0 F S X=$O(^IBA(355.8,"B",X)) Q:X="" D
. Q:+X'=DFN
. S N="" F S N=$O(^IBA(355.8,"B",X,N)) Q:N="" D
.. S AA=0 F S AA=$O(^IBA(355.81,AA)) Q:(AA="")!(AA="B") D
... I $P(^IBA(355.81,AA,0),"^",2)=N D
.... S SPN=$P(^IBA(355.81,AA,0),"^",1)
.... S EFFDT=$P(^IBA(355.81,AA,0),"^",5)
.... S EXPDT=$P(^IBA(355.81,AA,0),"^",6)
.... Q:'$D(^DPT(SPN,0))
.... S BDOB=$P(^DPT(SPN,0),"^",3)
.... Q:$P(^DPT(SPN,0),"^",16)-BDOB>365 ; Baby's Registration date minus DOB
.... S LINE=^DPT(SPN,0)
.... ; The last baby will be printed first
.... S SPFLAG=SPFLAG+1,NEWBAR(9999999-BDOB,SPN)=$P(LINE,"^",1)_"^"_BDOB_"^"_$P(LINE,"^",9)_"^"_EFFDT_"^"_EXPDT
GETQ Q
;
EDIT ;-- edit sponsor or primary care ... called from DGRPE
I DGRPANN["1" D
. D SPON^IBCNSU41(DFN)
I DGRPANN["2" D
. W !,"Edit Primary Provider information." H 3 Q
;
Q
;
NEWBDT(DFN) ;-- Get baby's DOB, check if DOB <1 year, returns FLAG and DOB
N DOB,FLAG,NOW
S FLAG=0
S DOB=$P(^DPT(DFN,0),"^",3)
D NOW^%DTC S NOW=X
I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;patient is not a newborn
S FLAG=1
Q FLAG_"^"_DOB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP15 3456 printed Dec 13, 2024@02:55:36 Page 2
DGRP15 ;ALB/MTC - TRICARE DEMOGRAPHIC DATA ;03/05/2004
+1 ;;5.3;Registration;**114,239,568,867**;Aug 13, 1993;Build 59
+2 ;
EN ;
+1 NEW X,Y,DGSA,SPFLAG,NEWBAR,LINE,NN,CNT
1 SET DGSA=""
+1 ;-- get sponsor info
+2 SET SPFLAG=0
+3 DO GET
+4 ;-- draw header
+5 SET (DGRPS,DGRPW)=15
DO H^DGRPU
+6 ;--
+7 SET Z=1
DO WW^DGRPV
WRITE " Sponsor Information:"
+8 IF DGSA
Begin DoDot:1
+9 SET Y=1
SET X=0
FOR
SET X=$ORDER(DGSA(X))
if 'X
QUIT
DO DISPON(X)
SET Y=Y+1
if Y>2
QUIT
End DoDot:1
+10 IF '$TEST
if 'SPFLAG
WRITE !,!,"No Sponsor Information available."
+11 IF SPFLAG
WRITE !?4,"Sponsored Newborn:"
Begin DoDot:1
+12 SET NN=""
SET CNT=0
FOR
SET NN=$ORDER(NEWBAR(NN))
if (NN="")!(CNT=2)
QUIT
Begin DoDot:2
+13 SET SPN=""
+14 FOR
SET SPN=$ORDER(NEWBAR(NN,SPN))
if (SPN="")!(CNT=2)
QUIT
Begin DoDot:3
+15 SET CNT=CNT+1
+16 WRITE !?7,"NAME : ",$PIECE(NEWBAR(NN,SPN),"^")
+17 WRITE !?8,"DOB : "
SET Y=$PIECE(NEWBAR(NN,SPN),"^",2)
XECUTE ^DD("DD")
WRITE Y
+18 WRITE !?8,"SSN : ",$PIECE(NEWBAR(NN,SPN),"^",3)
+19 WRITE !?6,"Effective Date : "
SET Y=$PIECE(NEWBAR(NN,SPN),"^",4)
XECUTE ^DD("DD")
WRITE Y
+20 WRITE ?38,"Expiration Date : "
SET Y=$PIECE(NEWBAR(NN,SPN),"^",5)
XECUTE ^DD("DD")
WRITE Y
+21 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF SPFLAG>2
WRITE "Sponsor has ",SPFLAG," sponsored newborn children."
+23 WRITE !
2 ;-- Primary Care
+1 ;
+2 ;-- get primary care data
+3 Begin DoDot:1
+4 NEW CT,GBL
SET GBL="GBL"
+5 DO TDATA^DGSDUTL(DFN,.CT,DT)
+6 IF CT>12
SET GBL(11,0)=""
Begin DoDot:2
+7 SET GBL(12,0)=" *** Additional assignment information exists ***"
End DoDot:2
+8 SET CT=0
FOR
SET CT=$ORDER(GBL(CT))
if 'CT!(CT>12)
QUIT
WRITE !,GBL(CT,0)
+9 QUIT
End DoDot:1
+10 ;
+11 ;-- goto main registration screen processing routine
+12 GOTO ^DGRPP
+13 ;
+14 QUIT
+15 ;
DISPON(SPON) ;-- This function will display the Sponsor designated by
+1 ; SPON.^
+2 ;
+3 WRITE !,!," Name : "
SET Z=$PIECE(DGSA(SPON,"SPON"),U)
SET Z1=30
DO WW1^DGRPV
+4 WRITE ?40,"Military Status : ",$PIECE(DGSA(SPON,"SPON"),U,4)
+5 WRITE !," DOB : "
SET Z=$PIECE(DGSA(SPON,"SPON"),U,2)
SET Z1=28
DO WW1^DGRPV
+6 WRITE ?35,"Branch of Service : ",$PIECE(DGSA(SPON,"SPON"),U,5)
+7 WRITE !," SSN : "
SET Z=$PIECE(DGSA(SPON,"SPON"),U,3)
SET Z1=15
DO WW1^DGRPV
+8 WRITE ?52,"Rank : ",$PIECE(DGSA(SPON,"SPON"),U,6)
+9 WRITE !," Prefix : "
SET Z=$PIECE(DGSA(SPON,"REL"),U,2)
SET Z1=12
DO WW1^DGRPV
+10 WRITE ?52,"Type : ",$PIECE(DGSA(SPON,"REL"),U,3)
+11 SET Y=$PIECE(DGSA(SPON,"REL"),U,4)
XECUTE ^DD("DD")
+12 WRITE !," Effective Date : ",Y
+13 SET Y=$PIECE(DGSA(SPON,"REL"),U,5)
XECUTE ^DD("DD")
+14 WRITE ?35,"Expiration Date: ",Y
+15 QUIT
+16 ;
GET ;-- get sponsor information and populate the DGSA array.
+1 NEW NEWB,SPON1,X,SPN,HDT,LINE,N,AA,BDOB
+2 DO GET^IBCNSU4(DFN,.DGSA)
+3 ; -- Find the Newborn sponsored info
+4 ; -- look at all of the patient's sponsor relationships
+5 SET X=0
FOR
SET X=$ORDER(^IBA(355.8,"B",X))
if X=""
QUIT
Begin DoDot:1
+6 if +X'=DFN
QUIT
+7 SET N=""
FOR
SET N=$ORDER(^IBA(355.8,"B",X,N))
if N=""
QUIT
Begin DoDot:2
+8 SET AA=0
FOR
SET AA=$ORDER(^IBA(355.81,AA))
if (AA="")!(AA="B")
QUIT
Begin DoDot:3
+9 IF $PIECE(^IBA(355.81,AA,0),"^",2)=N
Begin DoDot:4
+10 SET SPN=$PIECE(^IBA(355.81,AA,0),"^",1)
+11 SET EFFDT=$PIECE(^IBA(355.81,AA,0),"^",5)
+12 SET EXPDT=$PIECE(^IBA(355.81,AA,0),"^",6)
+13 if '$DATA(^DPT(SPN,0))
QUIT
+14 SET BDOB=$PIECE(^DPT(SPN,0),"^",3)
+15 ; Baby's Registration date minus DOB
if $PIECE(^DPT(SPN,0),"^",16)-BDOB>365
QUIT
+16 SET LINE=^DPT(SPN,0)
+17 ; The last baby will be printed first
+18 SET SPFLAG=SPFLAG+1
SET NEWBAR(9999999-BDOB,SPN)=$PIECE(LINE,"^",1)_"^"_BDOB_"^"_$PIECE(LINE,"^",9)_"^"_EFFDT_"^"_EXPDT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
GETQ QUIT
+1 ;
EDIT ;-- edit sponsor or primary care ... called from DGRPE
+1 IF DGRPANN["1"
Begin DoDot:1
+2 DO SPON^IBCNSU41(DFN)
End DoDot:1
+3 IF DGRPANN["2"
Begin DoDot:1
+4 WRITE !,"Edit Primary Provider information."
HANG 3
QUIT
End DoDot:1
+5 ;
+6 QUIT
+7 ;
NEWBDT(DFN) ;-- Get baby's DOB, check if DOB <1 year, returns FLAG and DOB
+1 NEW DOB,FLAG,NOW
+2 SET FLAG=0
+3 SET DOB=$PIECE(^DPT(DFN,0),"^",3)
+4 DO NOW^%DTC
SET NOW=X
+5 ;patient is not a newborn
IF $$FMDIFF^XLFDT(NOW,DOB,1)>365
QUIT
+6 SET FLAG=1
+7 QUIT FLAG_"^"_DOB
