Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIE17

DIE17.m

Go to the documentation of this file. 
  1. DIE17 ;SFISC/GFT-COMPILED TMPLT UTIL ;9:08 AM  22 Oct 1999 [ 04/02/2003   8:25 AM ]
  1.  ;;22.0;VA FileMan;**1001**;APR 1, 2003
  1.  ;;22.0;VA FileMan;**4,11**;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  I $D(DTOUT) S X="" G OUT
  1.  G:$A(X)-94 X:'$P(DW,";E",2),@("T^"_DNM)
  1.  I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " S D="" G X
  1.  I $D(DIE("NO^")),X?1"^"1.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " S D="" G X
  1.  I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE17
  1.  S X=$P(X,U,2),DIC(0)="E" G OUT
  1. Z ;
  1.  S DL=1,X=0
  1. OUT ;
  1.  I 0[X S DM=DW D FILE G ABORT:DL=1,R
  1.  S DIC="^DD("_DP_"," G OJ:'$D(^DIE(DIEZ,"AB")) S DIEZAB=$S(DL=1:U,1:DNM(DL,0)_U_DNM(DL)) I X?1"@".N,$D(^("AB",DIEZAB,X)) S DNM=^(X) G JMP
  1.  S DDBK=0 I $D(DIE("NO^")),DIE("NO^")["BACK" D DR S DDBK=1,DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)) D S^DIE0"
  1.  E  S DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)),DIC(0)[""F""!'$D(^(Y,""///""))"
  1.  S DIC="^DD("_DP_"," D ^DIC S DIC=DIE I Y<0 S D="" W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED "
  1.  I DDBK K DR S DR(1,DP)=^DIE(DIEZ,"ROU"),DR=DI
  1.  K A0,A1,DDBK,DIC,DTOUT G X:Y<0 S DNM=^DIE(DIEZ,"AB",DIEZAB,+Y)
  1. JMP K DIEZAB D FILE S Y=DNM,DNM=$P(Y,U,2),DQ=+Y,D=0 D @("DE^"_DNM) G @Y
  1.  ;
  1. OJ I X?1"@".N,$D(^DIE("AF",X,DIEZ)) S DNM=^(DIEZ)
  1.  E  S DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ)),DIC(0)[""F""!'$D(^(DIEZ,""///""))" D ^DIC K DIC S DIC=DIE G X:Y<0 S DNM=^DIE("AF",DP,+Y,DIEZ)
  1.  G JMP
  1. F ;
  1.  S DC=$S($D(X)#2:X,1:0) D FILE S X=DC Q
  1. FILE ;
  1.  K DQ Q:$D(DG)<9  S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
  1. Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
  1.  I DU'<0 S ^(DU)=DV,DU=-2
  1.  G E1:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
  1. DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y
  1. PC S $P(DV,U,DW)=DG(DQ) G Y
  1.  ;
  1. IX D:$D(DE(DQ))#2 @DE(DQ)
  1. K K DE(DQ)
  1. E1 S DQ=$O(DE(" ")) I DQ'="" G IX:$D(DG(DQ)),K
  1.  K DG,DE,DIFLD S DQ=0 Q
  1. 1 ;
  1.  D FILE
  1. R D UP G @("R"_DQ_U_DNM)
  1.  ;
  1. UP S DNM=DNM(DL),DQ=DNM(DL,0) K DTOUT,DNM(DL) I $D(DIEC(DL)) D DIEC^DIE1 G U
  1.  S DIEL=DIEL-1,%=2,DA=DA(1) K DA(1)
  1. DA I $D(DA(%)) S DA(%-1)=DA(%) K DA(%) S %=%+1 G DA
  1.  S DIIENS=$P(DIIENS,",",2,999)
  1. U S DL=DL-1 Q
  1.  ;
  1. X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G Z:$D(DB(DQ))
  1. B G @(DQ_U_DNM)
  1. N ;
  1.  D DOWN S DA=$P(DC,U,4),$P(DIIENS,",")=DA,D=0 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
  1. D1 S @("D"_DIEL)=DA G @(DGO)
  1. M ;
  1.  S DD=X D DOWN S DO(2)=$P(DC,"^",2),DO=DOW_"^"_DO(2)_"^"_$P(DC,"^",4,5),DIC(0)="LM"_$S($D(DB(DNM(DL,0))):"X",1:"QE") I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
  1.  E  I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
  1.  K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX")
  1.  K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC K DIC("PTRIX")
  1.  I Y>0 S DA=+Y,$P(DIIENS,",")=DA,X=$P(Y,U,2),D=$P(Y,U,3) G D1
  1.  D UP G @(DQ_U_DNM)
  1.  ;
  1. DOWN S DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ D FILE
  1.  F %=DL+1:-1:1 I $D(DA(%)) S DA(%+1)=DA(%)
  1.  S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_""",",DIEL=DIEL+1,DIIENS=","_DIIENS Q
  1. ABORT D E S Y(DM)="" Q
  1. 0 ;
  1.  D FILE
  1. E D FIREREC K:$D(DIEZTMP)#2 @DIEZTMP
  1.  K DIP,Y,DE,DOW,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB,DIEL,DGO,DICRREC Q
  1. DR ;
  1.  N F,DA I $E(DR)="[" S %X="^DIE(DIEZ,""DR"",",%Y="DR(" D %XY^%RCR S DR=DR(DL,DP) Q
  1.  S F=0 D DICS^DIA F DDW=1:1 S DDW1=$P(DR,";",DDW) Q:DDW1=""  I $D(^DD(DI,+DDW1,0)),+$P(^(0),U,2)!(DDW1[":") S X=+DDW1,D(F)=+$P(DDW1,":",2) S:'D(F) D(F)=X D RANGE^DIA1
  1.  K DDW,DDW1 Q
  1.  ;
  1. FIREREC ;Fire the record level xrefs
  1.  Q:'$D(DIEZRXR)&$S($D(DIEZTMP)#2:'$D(@DIEZTMP@("R")),1:1)
  1.  N DA,DIE,DIEZXR,DIIENS,DIKEY,DP
  1.  ;
  1.  S DP=0 F  S DP=$O(DIEZRXR(DP)) Q:'DP  D
  1.  . S DIIENS=" " F  S DIIENS=$O(DIEZRXR(DP,DIIENS)) Q:DIIENS=""  D
  1.  .. S DIE=DIEZRXR(DP,DIIENS)
  1.  .. D DA^DILF(DIIENS,.DA)
  1.  .. S DIEZXR=0 F  S DIEZXR=$O(DIEZRXR(DP,DIEZXR)) Q:DIEZXR'=+DIEZXR  D
  1.  ... I $D(DIEZAR(DP,DIEZXR))#2 N DIEXEC S DIEXEC="K" D @DIEZAR(DP,DIEZXR)
  1.  ;
  1.  ;Fire record level indexes for triggered fields not in the template
  1.  S DP=0 F  S DP=$O(@DIEZTMP@("R",DP)) Q:'DP  D
  1.  . S DIIENS=" " F  S DIIENS=$O(@DIEZTMP@("R",DP,DIIENS)) Q:DIIENS=""  D
  1.  .. D DA^DILF(DIIENS,.DA)
  1.  .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIEZTMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A"))
  1.  ;
  1.  ;If any keys are invalid, restore values
  1.  D:$D(DIKEY)>9 RESTORE^DIE1(.DIKEY,DIEZTMP)
  1.  ;
  1.  K DIEFIRE,DIEZRXR,@DIEZTMP@("V")
  1.  Q
  1.  ;
  1.  ;===========
  1.  ;  $$UNIQUE
  1.  ;===========
  1.  ;Called from compiled routine.
  1.  ;Look at actual (untruncated) values in the matching indexes.
  1.  ;Return 1 if unique.
  1.  ;In:
  1.  ; DIUIR    = Root of matching uniqueness index
  1.  ; DISETX   = Entry point to set X array
  1.  ; DIMAXL(order#) = max length of subscript with order #
  1.  ;
  1. UNIQUE(X,DA,DIUIR,DISETX,DIMAXL) ;
  1.  N DIDASV,DIIENS,DIIENSC,DINDX,DINS,DIUNIQ,DIXSV,I,O
  1.  ;
  1.  M DIDASV=DA,DIXSV=X
  1.  S DIIENSC=$$IENS(.DA)
  1.  ;
  1.  S DIUNIQ=1,DINS=$QL(DIUIR),DINDX=DIUIR
  1.  F  S DINDX=$Q(@DINDX) Q:$NA(@DINDX,DINS)'=DIUIR  D  Q:'DIUNIQ
  1.  . ;Set DA array, quit if this is index for current record
  1.  . S DIIENS=$E(DINDX,$L(DIUIR)+1,$L(DINDX)-1),L=$L(DIIENS,",")
  1.  . S DA=$P(DIIENS,",",L) F I=1:1:L-1 S DA(I)=$P(DIIENS,",",L-I)
  1.  . S DIIENS=$$IENS(.DA) Q:DIIENS=DIIENSC
  1.  . I '$D(DIMAXL) S DIUNIQ=0 Q
  1.  . ;
  1.  . ;Set the X array for the indexed record and compare
  1.  . D @(DISETX_"(""ONFILE"")")
  1.  . S O=0 F  S O=$O(DIMAXL(O)) Q:'O  Q:X(O)'=DIXSV(O)
  1.  . S:'O DIUNIQ=0
  1.  ;
  1.  K DA,X M DA=DIDASV,X=DIXSV
  1.  Q DIUNIQ
  1.  ;
  1. UNIQFERR ;The field is part of a key and is not unique
  1.  I '$D(ZTQUEUED),'$D(DDS) D
  1.  . W $C(7)_"??"
  1.  . W:'$D(DB(DQ)) !,"     Another entry already exists with this key value."
  1.  K DIEFXREF S ^("N")=@DIEZTMP@("V",DP,DIIENS,DIFLD,"O")
  1.  G:$D(DB(DQ)) Z
  1.  S X="?BAD"
  1.  G @("QS^"_DNM)
  1.  ;
  1. IENS(DA) ;Return IENS from DA array
  1.  N I,IENS
  1.  S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_","
  1.  Q IENS
  1.  ;
  1. TRIG ;Save info for record level indexes on a triggered field.
  1.  ;Called by DICR (via @DICRREC)
  1.  N DIE,DIE17RXR,OLD,XR
  1.  S OLD=DIU
  1.  ;
  1.  ;Get record level indexes on triggered field
  1.  D LOADFLD^DIKC1(DIH,DIG,"KS","",$NA(@DIEZTMP@("V")),"","DIE17RXR","",.RLIST,"f")
  1.  Q:RLIST=""
  1.  ;
  1.  S DIE=$$OREF^DILF($NA(@$$FROOTDA^DIKCU(DIH)))
  1.  I $D(^DIE("AF",DIH,DIG,DIEZ)) D
  1.  . N N,PC,RL,XR
  1.  . S RL=RLIST
  1.  . F  D  Q:RL=""
  1.  .. F PC=1:1:$L(RL,U) S XR=$P(RL,U,PC) S:XR DIEZRXR(DIH,XR)=""
  1.  .. S N=$G(N)+1,RL=$G(RLIST(N))
  1.  . S DIEZRXR(DIH,DICRIENS)=DIE
  1.  E  M @DIEZTMP@("R")=DIE17RXR S @DIEZTMP@("R",DIH,DICRIENS)=DIE
  1.  ;
  1.  ;Save the old value of the field
  1.  S @DIEZTMP@("V",DIH,DICRIENS,DIG,"O")=OLD S:$D(^("F"))[0 ^("F")=OLD
  1.  Q