DICATTD8 ;SFISC/GFT - VARIABLE POINTER FIELDS ;12:19 PM 13 Dec 2001
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
GET ;
K DICATTVP
F DA=0:0 S DA=$O(^DD(DICATTA,DICATTF,"V",DA)) Q:'DA I $D(^(DA,0)) D
.F DR=1:1:6 S DICATTVP(DA,DR)=$P(^(0),U,DR)
.I $G(^(1))]"" S DICATTVP(DA,7)=^(1)
.I $G(^(2))]"" S DICATTVP(DA,8)=^(2)
Q
;
Y(I,J) ;defaults for Page 2.8
S Y=$G(DICATTVP(I,J)) Q
;
PRE8 ;PRE-ACTION for Page 8
F I=1:1:5 D P(I)
I $P($G(^DD(+$$GET^DDSVALF(DICATTVP+90,"DICATT8",2.8,""),0,"DI")),U,2)["Y" D PUT(3,"n"),UNED^DDSUTL(3,,,1,"") ;ARCHIVE File can't be LAYGO'd
Q
;
P(FLD) ;
D PUT(FLD,$G(DICATTVP(DICATTVP,$$V(FLD)))) Q
;
V(FLD) Q $E(24678,FLD) ;Field 1 is .02, etc
;
DICS ;
I DUZ(0)'="@" S DIC("S")="I Y-1.1 Q:'$L($G(^(0,""RD""))) I $TR(DUZ(0),^(""RD""))'=DUZ(0)" Q
S DIC("S")="I Y-1.1"
Q
;
POST8 ;POST-ACTION for Page 8
N I,Y
F I=1:1:5 S Y=$$GET^DDSVALF(I,"DICATTVP",8,"",""),DICATTVP(DICATTVP,$$V(I))=Y
I DICATTVP(DICATTVP,7)="" S DICATTVP(DICATTVP,8)="" ;if no SCREEN, no EXPLANATION
F I=1:1:5 D PUT(I,"") ;clean out the screen
S DICATTLN=18 ;so 'IS THIS FIELD MULTIPLE' will be asked -- a V-P field can be expected to take up 18 bytes of storage
Q
;
G(I) Q $$GET^DDSVALF(I,"DICATT8",2.8,"I","")
;
PUT(I,VAL) D PUT^DDSVALF(I,"DICATTVP",8,VAL,"I","") Q
;
POSTVP ;
N I,S,ERR
D RECALL^DILFD(1,DICATTB_",",DUZ) ;we've looked up other files, so remember this one
S DICATTMN="",DICATT2N="V",DICATT3N="",DICATT5N=""
F I=91:1:97 S DICATTVP(I-90,1)=$$G(I)
F I=91.1:1:97.1 S S=$$G(I) I S]""!$D(DICATTVP(I-90.1,3)) S DICATTVP(I-90.1,3)=S ;ORDER
F I=0:0 S I=$O(DICATTVP(I)) Q:'I D I $D(ERR) Q
.I '$G(DICATTVP(I,1)) K DICATTVP(I) Q
.I $D(I(1,DICATTVP(I,1))) S ERR="DUPLICATE FILE NUMBER" Q
.S I(1,DICATTVP(I,1))=""
.I $G(DICATTVP(I,2))="" S ERR="MESSAGE REQUIRED" Q
.I '$G(DICATTVP(I,3)) S ERR="ORDER NUMBER REQUIRED" Q
.I $D(I(3,DICATTVP(I,3))) S ERR="DUPLICATE ORDER NUMBER" Q
.S I(3,DICATTVP(I,3))=""
.I $G(DICATTVP(I,4))="" S ERR="PREFIX REQUIRED" Q
.I DICATTVP(I,4)["""" S ERR="BAD PREFIX" Q
.I $D(I(4,DICATTVP(I,4))) S ERR="DUPLICATE PREFIX" Q
.S I(4,DICATTVP(I,4))=""
.S S=$G(DICATTVP(I,7))]"",DICATTVP(I,5)=$E("ny",S+1)
.I S,$G(DICATTVP(I,8))="" S ERR="SCREEN MUST HAVE EXPLANATION" Q
I '$D(ERR) Q
S DDSBR=90+I,S(1)="ERROR IN VARIABLE-POINTER SPECIFICATIONS, FILE "_$G(DICATTVP(I,1)),S(2)=ERR,S(3)="$$EOP"
D HLP^DDSUTL(.S)
Q
;
FILE ;come here from ^DICATTDE
N I,DIK,DA
F I=0:0 S I=$O(^DD(DICATTA,DICATTF,"V","B",I)) Q:'I K ^DD(+I,0,"PT",DICATTA,DICATTF) ;delete old POINTED-TOs
K ^DD(DICATTA,DICATTF,"V") ;all other cross_references are with the subfile
I $G(DICATT2N)'["V" Q ;stop now if field is no longer V-P!
S DA=0 F I=1:1 S DA=$O(DICATTVP(DA)) Q:'DA D
.S DICATTVP(DA,5)=$E("ny",$G(DICATTVP(DA,7))]""+1)
.F DIK=1:1:6 S $P(^DD(DICATTA,DICATTF,"V",I,0),U,DIK)=$G(DICATTVP(DA,DIK))
.F DIK=7,8 I $D(DICATTVP(DA,DIK)) S ^(DIK-6)=DICATTVP(DA,DIK)
S ^DD(DICATTA,DICATTF,"V",0)="^.12P^",DA(2)=DICATTA,DA(1)=DICATTF
S DIK="^DD("_DICATTA_","_DICATTF_",""V""," D IXALL^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTD8 3382 printed Nov 22, 2024@17:55:40 Page 2
DICATTD8 ;SFISC/GFT - VARIABLE POINTER FIELDS ;12:19 PM 13 Dec 2001
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
GET ;
+1 KILL DICATTVP
+2 FOR DA=0:0
SET DA=$ORDER(^DD(DICATTA,DICATTF,"V",DA))
if 'DA
QUIT
IF $DATA(^(DA,0))
Begin DoDot:1
+3 FOR DR=1:1:6
SET DICATTVP(DA,DR)=$PIECE(^(0),U,DR)
+4 IF $GET(^(1))]""
SET DICATTVP(DA,7)=^(1)
+5 IF $GET(^(2))]""
SET DICATTVP(DA,8)=^(2)
End DoDot:1
+6 QUIT
+7 ;
Y(I,J) ;defaults for Page 2.8
+1 SET Y=$GET(DICATTVP(I,J))
QUIT
+2 ;
PRE8 ;PRE-ACTION for Page 8
+1 FOR I=1:1:5
DO P(I)
+2 ;ARCHIVE File can't be LAYGO'd
IF $PIECE($GET(^DD(+$$GET^DDSVALF(DICATTVP+90,"DICATT8",2.8,""),0,"DI")),U,2)["Y"
DO PUT(3,"n")
DO UNED^DDSUTL(3,,,1,"")
+3 QUIT
+4 ;
P(FLD) ;
+1 DO PUT(FLD,$GET(DICATTVP(DICATTVP,$$V(FLD))))
QUIT
+2 ;
V(FLD) ;Field 1 is .02, etc
QUIT $EXTRACT(24678,FLD)
+1 ;
DICS ;
+1 IF DUZ(0)'="@"
SET DIC("S")="I Y-1.1 Q:'$L($G(^(0,""RD""))) I $TR(DUZ(0),^(""RD""))'=DUZ(0)"
QUIT
+2 SET DIC("S")="I Y-1.1"
+3 QUIT
+4 ;
POST8 ;POST-ACTION for Page 8
+1 NEW I,Y
+2 FOR I=1:1:5
SET Y=$$GET^DDSVALF(I,"DICATTVP",8,"","")
SET DICATTVP(DICATTVP,$$V(I))=Y
+3 ;if no SCREEN, no EXPLANATION
IF DICATTVP(DICATTVP,7)=""
SET DICATTVP(DICATTVP,8)=""
+4 ;clean out the screen
FOR I=1:1:5
DO PUT(I,"")
+5 ;so 'IS THIS FIELD MULTIPLE' will be asked -- a V-P field can be expected to take up 18 bytes of storage
SET DICATTLN=18
+6 QUIT
+7 ;
G(I) QUIT $$GET^DDSVALF(I,"DICATT8",2.8,"I","")
+1 ;
PUT(I,VAL) DO PUT^DDSVALF(I,"DICATTVP",8,VAL,"I","")
QUIT
+1 ;
POSTVP ;
+1 NEW I,S,ERR
+2 ;we've looked up other files, so remember this one
DO RECALL^DILFD(1,DICATTB_",",DUZ)
+3 SET DICATTMN=""
SET DICATT2N="V"
SET DICATT3N=""
SET DICATT5N=""
+4 FOR I=91:1:97
SET DICATTVP(I-90,1)=$$G(I)
+5 ;ORDER
FOR I=91.1:1:97.1
SET S=$$G(I)
IF S]""!$DATA(DICATTVP(I-90.1,3))
SET DICATTVP(I-90.1,3)=S
+6 FOR I=0:0
SET I=$ORDER(DICATTVP(I))
if 'I
QUIT
Begin DoDot:1
+7 IF '$GET(DICATTVP(I,1))
KILL DICATTVP(I)
QUIT
+8 IF $DATA(I(1,DICATTVP(I,1)))
SET ERR="DUPLICATE FILE NUMBER"
QUIT
+9 SET I(1,DICATTVP(I,1))=""
+10 IF $GET(DICATTVP(I,2))=""
SET ERR="MESSAGE REQUIRED"
QUIT
+11 IF '$GET(DICATTVP(I,3))
SET ERR="ORDER NUMBER REQUIRED"
QUIT
+12 IF $DATA(I(3,DICATTVP(I,3)))
SET ERR="DUPLICATE ORDER NUMBER"
QUIT
+13 SET I(3,DICATTVP(I,3))=""
+14 IF $GET(DICATTVP(I,4))=""
SET ERR="PREFIX REQUIRED"
QUIT
+15 IF DICATTVP(I,4)[""""
SET ERR="BAD PREFIX"
QUIT
+16 IF $DATA(I(4,DICATTVP(I,4)))
SET ERR="DUPLICATE PREFIX"
QUIT
+17 SET I(4,DICATTVP(I,4))=""
+18 SET S=$GET(DICATTVP(I,7))]""
SET DICATTVP(I,5)=$EXTRACT("ny",S+1)
+19 IF S
IF $GET(DICATTVP(I,8))=""
SET ERR="SCREEN MUST HAVE EXPLANATION"
QUIT
End DoDot:1
IF $DATA(ERR)
QUIT
+20 IF '$DATA(ERR)
QUIT
+21 SET DDSBR=90+I
SET S(1)="ERROR IN VARIABLE-POINTER SPECIFICATIONS, FILE "_$GET(DICATTVP(I,1))
SET S(2)=ERR
SET S(3)="$$EOP"
+22 DO HLP^DDSUTL(.S)
+23 QUIT
+24 ;
FILE ;come here from ^DICATTDE
+1 NEW I,DIK,DA
+2 ;delete old POINTED-TOs
FOR I=0:0
SET I=$ORDER(^DD(DICATTA,DICATTF,"V","B",I))
if 'I
QUIT
KILL ^DD(+I,0,"PT",DICATTA,DICATTF)
+3 ;all other cross_references are with the subfile
KILL ^DD(DICATTA,DICATTF,"V")
+4 ;stop now if field is no longer V-P!
IF $GET(DICATT2N)'["V"
QUIT
+5 SET DA=0
FOR I=1:1
SET DA=$ORDER(DICATTVP(DA))
if 'DA
QUIT
Begin DoDot:1
+6 SET DICATTVP(DA,5)=$EXTRACT("ny",$GET(DICATTVP(DA,7))]""+1)
+7 FOR DIK=1:1:6
SET $PIECE(^DD(DICATTA,DICATTF,"V",I,0),U,DIK)=$GET(DICATTVP(DA,DIK))
+8 FOR DIK=7,8
IF $DATA(DICATTVP(DA,DIK))
SET ^(DIK-6)=DICATTVP(DA,DIK)
End DoDot:1
+9 SET ^DD(DICATTA,DICATTF,"V",0)="^.12P^"
SET DA(2)=DICATTA
SET DA(1)=DICATTF
+10 SET DIK="^DD("_DICATTA_","_DICATTF_",""V"","
DO IXALL^DIK
+11 QUIT
