- 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 Feb 19, 2025@00:12 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