VAQPST04 ;ALB/JFP - PDX, POST INIT ROUTINE ;01JUN93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
ALL ; --Creates an entry in the Segment Group file 394.84 of all segments
I '$D(^VAT(394.71)) QUIT
;IF IT'S ALREADY THERE, DELETE IT
S DA=""
F S DA=+$O(^VAT(394.84,"B","ALL",DA)) Q:('DA) D
.Q:($P(^VAT(394.84,DA,0),"^",2)=0)
.S DIK="^VAT(394.84,"
.D ^DIK K DIK
W !," Creating a segment group called ""ALL"" "
W !," This group will contain all data segments"
S DIC="^VAT(394.84,",DIC(0)="L",DLAYGO=394.84,X="ALL"
S DIC("DR")=".02///PUBLIC" ; -- Public
K DD,DO
D FILE^DICN K DIC,DLAYGO,X,DINUM
I Y=-1 QUIT
; -- Add segments
S DA=$P(Y,U,1),DIE="^VAT(394.84,",SEG=""
F S SEG=$O(^VAT(394.71,"B",SEG)) Q:SEG="" D S1
W !,"Done"
K SEG,DA,DIE
QUIT
S1 ; -- Update existing entry
W !," ",SEG," - added"
S DR="10///"_SEG
S DR(2,394.841)=".01///"_SEG
D ^DIE K DR
QUIT
;
;
COP ; -- Creates entries in Segment group file from Health Summary Type file^GMT(142,
N TMP
I '$D(^GMT(142)) QUIT
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Create entries in Segment Groups from Health Summary Type File"
D ^DIR K DIR
I ('Y)!($D(DUOUT))!($D(DTOUT)) QUIT
;
S GRP=""
F S GRP=$O(^GMT(142,"B",GRP)) Q:GRP="" D G1
QUIT
;
G1 ;
;IF IT'S ALREADY THERE, DELETE IT
S DA=""
F S DA=+$O(^VAT(394.84,"B",GRP,DA)) Q:('DA) D
.Q:($P(^VAT(394.84,DA,0),"^",2)=0)
.S DIK="^VAT(394.84,"
.D ^DIK K DIK
Q:(GRP="GMTS HS ADHOC OPTION")
S ENTRY="",ENTRY=$O(^GMT(142,"B",GRP,ENTRY))
S DIC="^VAT(394.84,",DIC(0)="L",DLAYGO=394.84,X=GRP
S DIC("DR")=".02///PUBLIC" ; -- Public
K DD,DO
D FILE^DICN K DIC,DLAYGO,X,DINUM
I Y=-1 QUIT
; -- Set components within entry
W !!,?3,GRP," <-- Segment group added, the list of components follows"
S DA=$P(Y,U,1),DIE="^VAT(394.84,",SEGPT=""
F S SEGPT=$O(^GMT(142,ENTRY,1,"C",SEGPT)) Q:SEGPT="" D S0
K SEG,DA,DIE
QUIT
;
S0 ;
S SEG=$P($G(^GMT(142.1,SEGPT,0)),U,4)
S SEGNM=$P($G(^GMT(142.1,SEGPT,0)),U,1)
;FILTER OUT NON-SUPPORTED COMPONENTS
I ((SEG'="")&($D(^VAT(394.71,"C",SEG)))) D S2
QUIT
;
S2 ; -- Update existing entry
W !,?10,SEG
S DR="10///"_SEG
S DR(2,394.841)=".01///"_SEG
;DETERMINE IF TIME & OCCURRENCE LIMITS ARE APPLICABLE
S TMP=$$LIMITS^VAQDBIH3(SEGPT)
;PUT TIME LIMIT OF 1 YEAR (IF APPLICABLE)
S:($P(TMP,"^",1)) DR(2,394.841)=DR(2,394.841)_";.04///1Y"
;PUT OCCURRENCE LIMIT OF 10 (IF APPLICABLE)
S:($P(TMP,"^",2)) DR(2,394.841)=DR(2,394.841)_";.05///10"
D ^DIE K DR
W ?16," - ",SEGNM
QUIT
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQPST04 2581 printed Sep 23, 2025@20:02:05 Page 2
VAQPST04 ;ALB/JFP - PDX, POST INIT ROUTINE ;01JUN93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
ALL ; --Creates an entry in the Segment Group file 394.84 of all segments
+1 IF '$DATA(^VAT(394.71))
QUIT
+2 ;IF IT'S ALREADY THERE, DELETE IT
+3 SET DA=""
+4 FOR
SET DA=+$ORDER(^VAT(394.84,"B","ALL",DA))
if ('DA)
QUIT
Begin DoDot:1
+5 if ($PIECE(^VAT(394.84,DA,0),"^",2)=0)
QUIT
+6 SET DIK="^VAT(394.84,"
+7 DO ^DIK
KILL DIK
End DoDot:1
+8 WRITE !," Creating a segment group called ""ALL"" "
+9 WRITE !," This group will contain all data segments"
+10 SET DIC="^VAT(394.84,"
SET DIC(0)="L"
SET DLAYGO=394.84
SET X="ALL"
+11 ; -- Public
SET DIC("DR")=".02///PUBLIC"
+12 KILL DD,DO
+13 DO FILE^DICN
KILL DIC,DLAYGO,X,DINUM
+14 IF Y=-1
QUIT
+15 ; -- Add segments
+16 SET DA=$PIECE(Y,U,1)
SET DIE="^VAT(394.84,"
SET SEG=""
+17 FOR
SET SEG=$ORDER(^VAT(394.71,"B",SEG))
if SEG=""
QUIT
DO S1
+18 WRITE !,"Done"
+19 KILL SEG,DA,DIE
+20 QUIT
S1 ; -- Update existing entry
+1 WRITE !," ",SEG," - added"
+2 SET DR="10///"_SEG
+3 SET DR(2,394.841)=".01///"_SEG
+4 DO ^DIE
KILL DR
+5 QUIT
+6 ;
+7 ;
COP ; -- Creates entries in Segment group file from Health Summary Type file^GMT(142,
+1 NEW TMP
+2 IF '$DATA(^GMT(142))
QUIT
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
+4 SET DIR("A")="Create entries in Segment Groups from Health Summary Type File"
+5 DO ^DIR
KILL DIR
+6 IF ('Y)!($DATA(DUOUT))!($DATA(DTOUT))
QUIT
+7 ;
+8 SET GRP=""
+9 FOR
SET GRP=$ORDER(^GMT(142,"B",GRP))
if GRP=""
QUIT
DO G1
+10 QUIT
+11 ;
G1 ;
+1 ;IF IT'S ALREADY THERE, DELETE IT
+2 SET DA=""
+3 FOR
SET DA=+$ORDER(^VAT(394.84,"B",GRP,DA))
if ('DA)
QUIT
Begin DoDot:1
+4 if ($PIECE(^VAT(394.84,DA,0),"^",2)=0)
QUIT
+5 SET DIK="^VAT(394.84,"
+6 DO ^DIK
KILL DIK
End DoDot:1
+7 if (GRP="GMTS HS ADHOC OPTION")
QUIT
+8 SET ENTRY=""
SET ENTRY=$ORDER(^GMT(142,"B",GRP,ENTRY))
+9 SET DIC="^VAT(394.84,"
SET DIC(0)="L"
SET DLAYGO=394.84
SET X=GRP
+10 ; -- Public
SET DIC("DR")=".02///PUBLIC"
+11 KILL DD,DO
+12 DO FILE^DICN
KILL DIC,DLAYGO,X,DINUM
+13 IF Y=-1
QUIT
+14 ; -- Set components within entry
+15 WRITE !!,?3,GRP," <-- Segment group added, the list of components follows"
+16 SET DA=$PIECE(Y,U,1)
SET DIE="^VAT(394.84,"
SET SEGPT=""
+17 FOR
SET SEGPT=$ORDER(^GMT(142,ENTRY,1,"C",SEGPT))
if SEGPT=""
QUIT
DO S0
+18 KILL SEG,DA,DIE
+19 QUIT
+20 ;
S0 ;
+1 SET SEG=$PIECE($GET(^GMT(142.1,SEGPT,0)),U,4)
+2 SET SEGNM=$PIECE($GET(^GMT(142.1,SEGPT,0)),U,1)
+3 ;FILTER OUT NON-SUPPORTED COMPONENTS
+4 IF ((SEG'="")&($DATA(^VAT(394.71,"C",SEG))))
DO S2
+5 QUIT
+6 ;
S2 ; -- Update existing entry
+1 WRITE !,?10,SEG
+2 SET DR="10///"_SEG
+3 SET DR(2,394.841)=".01///"_SEG
+4 ;DETERMINE IF TIME & OCCURRENCE LIMITS ARE APPLICABLE
+5 SET TMP=$$LIMITS^VAQDBIH3(SEGPT)
+6 ;PUT TIME LIMIT OF 1 YEAR (IF APPLICABLE)
+7 if ($PIECE(TMP,"^",1))
SET DR(2,394.841)=DR(2,394.841)_";.04///1Y"
+8 ;PUT OCCURRENCE LIMIT OF 10 (IF APPLICABLE)
+9 if ($PIECE(TMP,"^",2))
SET DR(2,394.841)=DR(2,394.841)_";.05///10"
+10 DO ^DIE
KILL DR
+11 WRITE ?16," - ",SEGNM
+12 QUIT
+13 ;
END ; -- End of code
+1 QUIT
