- XUA4A72 ;SFISC/RWF - Person class API's ;08/05/2004 15:53
- ;;8.0;KERNEL;**27,49,74,132,222,300,327,357**;Jul 10, 1995;Build 2
- ; Entry Points (DBIA 1625)
- ; $$GET - Returns active class, given duz and date.
- ; $$IEN2CODE - Returns VA CODE from PERSON CLASS file, given IEN.
- ; $$CODE2TXT - Returns HCFA text from PERSON CLASS file, given IEN
- ; or VA CODE.
- Q ;No access from top.
- GET(IEN,DATE) ;sr. Get the active class on a date
- ;IEN of user.
- N X1,Y1,D
- S:$G(DATE)="" DATE=DT S D=DATE
- ;The return is file 200 ien_^_NODE
- S X1=$$GETUE(IEN,DATE) I X1'>0 Q X1
- S X1=$P(X1,"^",2,99) ;or X1=^VA(200,IEN,"USC1",+X1,0)
- S Y1=$G(^USC(8932.1,+X1,0))
- ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
- Q +X1_U_$P(Y1,U,1,3)_U_$P(X1,U,2,3)_U_$P(Y1,U,6)_U_$P(Y1,U,9)
- ;
- IEN2CODE(IEN) ;sr. Get the code for an IEN
- Q $P($G(^USC(8932.1,+$G(IEN),0)),U,6)
- ;
- IEN2DATA(IEN) ;Get person class data for an IEN
- Q $G(^USC(8932.1,+$G(IEN),0))
- ;
- CODE2TXT(CODE) ;sr. Convert IEN or V-code to text
- I CODE?1"V"1.N S CODE=$$VCLK(CODE)
- Q $P($G(^USC(8932.1,+CODE,0)),U,1,3)
- ;
- VCLK(X) ;Lookup a V-code, Return IEN
- Q $O(^USC(8932.1,"F",X,0))
- ;
- GETUE(IEN,DATE) ;private, Get the user entry
- N D,X,Y,XUOK
- Q:'$D(^VA(200,+$G(IEN),0)) -1
- Q:$O(^VA(200,IEN,"USC1",0))="" -1
- S XUOK=0
- S D=$O(^VA(200,IEN,"USC1","AD",DATE))
- F S D=$O(^VA(200,IEN,"USC1","AD",D),-1) Q:D="" D Q:XUOK
- . S Y=""
- . F S Y=$O(^VA(200,IEN,"USC1","AD",D,Y),-1) Q:'Y D Q:XUOK
- . . S X=$G(^VA(200,IEN,"USC1",Y,0))
- . . I $P(X,U,2),DATE'<$P(X,U,2),DATE'>$P(X,U,3)!($P(X,U,3)="") S XUOK=1
- Q $S(XUOK:Y_U_X_U_U,1:-2)
- ;
- REMOVE ;Allow privileged user to remove a wrong entry in the users file.
- N XUDA,XUDA1,XUWT,%
- S XUDA1=+$$LOOKUP^XUSER Q:XUDA1'>0
- W !,"This user has the following Person Class enties:"
- S XUWT=^DD(8932.1,0,"ID","WRITE")
- F XUDA=0:0 S XUDA=$O(^VA(200,XUDA1,"USC1",XUDA)) Q:XUDA'>0 S %=+$G(^(XUDA,0)) I %>0 W !,$P(^USC(8932.1,%,0),U) X XUWT
- S DIR(0)="Y",DIR("A")="Are you sure you want to remove ALL these entries" D ^DIR Q:$D(DIRUT)!(Y'=1)
- F XUDA=0:0 S XUDA=$O(^VA(200,XUDA1,"USC1",XUDA)) Q:XUDA'>0 S DIK="^VA(200,DA(1),""USC1"",",DA=XUDA,DA(1)=XUDA1 D ^DIK
- Q
- ;
- TERM(IEN,DATE) ;Called from XUSTERM, Set the expiration date for a user being terminated.
- N Y1
- Q:$G(DATE)'>0
- S Y1=$$GETUE(IEN,DATE)
- I Y1'>0!$L($P(Y1,"^",4)) Q
- D OLD(IEN,+Y1,DATE)
- Q
- ;
- SET01 ;Called from the X-ref on the .01 field
- Q:$P(^VA(200,DA(1),"USC1",DA,0),U,2)>0
- S $P(^VA(200,DA(1),"USC1",DA,0),U,2)=DT ;Trigger date
- D UPDATE(200.05,2,DT)
- ;
- SET2 ;Call from the X-ref on the Effective Date field
- N L,REC
- S L=$O(^VA(200,DA(1),"USC1",DA),-1) Q:L'>0
- S REC=^VA(200,DA(1),"USC1",L,0)
- I $P(REC,U,3)="" D OLD(DA(1),L,$$MAX^XLFMTH(X,$P(REC,U,2))) ;Inactivate the old one
- Q
- KILL2 ;Call from the X-ref on the Effective Date field
- N L
- S L=$O(^VA(200,DA(1),"USC1",DA),-1) Q:L'>0
- I $P(^VA(200,DA(1),"USC1",L,0),U,3)=X D OLD(DA(1),L,"")
- Q
- ;
- OLD(D0,D1,DATE) ;Inactivate the old one (Expiration Date)
- N DA,X
- S $P(^VA(200,D0,"USC1",D1,0),U,3)=DATE ;Inactivate the old one
- S DA(1)=D0,DA=D1 D UPDATE(200.05,3,DATE)
- Q
- UPDATE(DIH,DIG,DIV,DIU) ;file,field,new value,old value
- S DIV=$G(DIV),DIU=$G(DIU),DIV(0)=DA(1),DIV(1)=DA
- D ^DICR:$O(^DD(DIH,DIG,1,0))>0
- Q
- DDS1 ;Called from Pre-action person class field
- N %,XUDA,XU
- I X]"" S %=^USC(8932.1,X,0),XU(1)=$P(%,U,1),XU(2)=" "_$P(%,U,2),XU(3)=" "_$P(%,U,3) D HLP^DDSUTL(.XU)
- Q:DA'>0 M XUDA=DA N DA ;Hide DA
- S %=$$GET^DDSVAL(DIE,.XUDA,3,"","I"),%=$S(%>0:1,1:0)
- D UNED^DDSUTL(2,,,%),UNED^DDSUTL(3,,,%)
- Q
- DDS2 ;Called from effective date on form
- N %,XUDA M XUDA=DA N DA ;Hide DA
- S XUDA=$O(^VA(200,XUDA(1),"USC1",XUDA),-1) Q:XUDA'>0
- S %=$$GET^DDSVAL(DIE,.XUDA,3,"","I") Q:%&(%<X) ;Already has value
- D PUT^DDSVAL(DIE,.XUDA,3,X,"","I")
- Q
- DDS3(%) ;Data validation
- I %=2,$$GET^DDSVAL(DIE,.DA,3,"","I")]"" D
- . S DDSERROR=1
- . D HLP^DDSUTL("This field is uneditable because Expired Date already has data")
- . Q
- I %=3,DDSOLD]"",X'=DDSOLD D
- . S DDSERROR=1
- . D HLP^DDSUTL("You cannot change the value of this field.")
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUA4A72 4205 printed Jan 18, 2025@03:10:08 Page 2
- XUA4A72 ;SFISC/RWF - Person class API's ;08/05/2004 15:53
- +1 ;;8.0;KERNEL;**27,49,74,132,222,300,327,357**;Jul 10, 1995;Build 2
- +2 ; Entry Points (DBIA 1625)
- +3 ; $$GET - Returns active class, given duz and date.
- +4 ; $$IEN2CODE - Returns VA CODE from PERSON CLASS file, given IEN.
- +5 ; $$CODE2TXT - Returns HCFA text from PERSON CLASS file, given IEN
- +6 ; or VA CODE.
- +7 ;No access from top.
- QUIT
- GET(IEN,DATE) ;sr. Get the active class on a date
- +1 ;IEN of user.
- +2 NEW X1,Y1,D
- +3 if $GET(DATE)=""
- SET DATE=DT
- SET D=DATE
- +4 ;The return is file 200 ien_^_NODE
- +5 SET X1=$$GETUE(IEN,DATE)
- IF X1'>0
- QUIT X1
- +6 ;or X1=^VA(200,IEN,"USC1",+X1,0)
- SET X1=$PIECE(X1,"^",2,99)
- +7 SET Y1=$GET(^USC(8932.1,+X1,0))
- +8 ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
- +9 QUIT +X1_U_$PIECE(Y1,U,1,3)_U_$PIECE(X1,U,2,3)_U_$PIECE(Y1,U,6)_U_$PIECE(Y1,U,9)
- +10 ;
- IEN2CODE(IEN) ;sr. Get the code for an IEN
- +1 QUIT $PIECE($GET(^USC(8932.1,+$GET(IEN),0)),U,6)
- +2 ;
- IEN2DATA(IEN) ;Get person class data for an IEN
- +1 QUIT $GET(^USC(8932.1,+$GET(IEN),0))
- +2 ;
- CODE2TXT(CODE) ;sr. Convert IEN or V-code to text
- +1 IF CODE?1"V"1.N
- SET CODE=$$VCLK(CODE)
- +2 QUIT $PIECE($GET(^USC(8932.1,+CODE,0)),U,1,3)
- +3 ;
- VCLK(X) ;Lookup a V-code, Return IEN
- +1 QUIT $ORDER(^USC(8932.1,"F",X,0))
- +2 ;
- GETUE(IEN,DATE) ;private, Get the user entry
- +1 NEW D,X,Y,XUOK
- +2 if '$DATA(^VA(200,+$GET(IEN),0))
- QUIT -1
- +3 if $ORDER(^VA(200,IEN,"USC1",0))=""
- QUIT -1
- +4 SET XUOK=0
- +5 SET D=$ORDER(^VA(200,IEN,"USC1","AD",DATE))
- +6 FOR
- SET D=$ORDER(^VA(200,IEN,"USC1","AD",D),-1)
- if D=""
- QUIT
- Begin DoDot:1
- +7 SET Y=""
- +8 FOR
- SET Y=$ORDER(^VA(200,IEN,"USC1","AD",D,Y),-1)
- if 'Y
- QUIT
- Begin DoDot:2
- +9 SET X=$GET(^VA(200,IEN,"USC1",Y,0))
- +10 IF $PIECE(X,U,2)
- IF DATE'<$PIECE(X,U,2)
- IF DATE'>$PIECE(X,U,3)!($PIECE(X,U,3)="")
- SET XUOK=1
- End DoDot:2
- if XUOK
- QUIT
- End DoDot:1
- if XUOK
- QUIT
- +11 QUIT $SELECT(XUOK:Y_U_X_U_U,1:-2)
- +12 ;
- REMOVE ;Allow privileged user to remove a wrong entry in the users file.
- +1 NEW XUDA,XUDA1,XUWT,%
- +2 SET XUDA1=+$$LOOKUP^XUSER
- if XUDA1'>0
- QUIT
- +3 WRITE !,"This user has the following Person Class enties:"
- +4 SET XUWT=^DD(8932.1,0,"ID","WRITE")
- +5 FOR XUDA=0:0
- SET XUDA=$ORDER(^VA(200,XUDA1,"USC1",XUDA))
- if XUDA'>0
- QUIT
- SET %=+$GET(^(XUDA,0))
- IF %>0
- WRITE !,$PIECE(^USC(8932.1,%,0),U)
- XECUTE XUWT
- +6 SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want to remove ALL these entries"
- DO ^DIR
- if $DATA(DIRUT)!(Y'=1)
- QUIT
- +7 FOR XUDA=0:0
- SET XUDA=$ORDER(^VA(200,XUDA1,"USC1",XUDA))
- if XUDA'>0
- QUIT
- SET DIK="^VA(200,DA(1),""USC1"","
- SET DA=XUDA
- SET DA(1)=XUDA1
- DO ^DIK
- +8 QUIT
- +9 ;
- TERM(IEN,DATE) ;Called from XUSTERM, Set the expiration date for a user being terminated.
- +1 NEW Y1
- +2 if $GET(DATE)'>0
- QUIT
- +3 SET Y1=$$GETUE(IEN,DATE)
- +4 IF Y1'>0!$LENGTH($PIECE(Y1,"^",4))
- QUIT
- +5 DO OLD(IEN,+Y1,DATE)
- +6 QUIT
- +7 ;
- SET01 ;Called from the X-ref on the .01 field
- +1 if $PIECE(^VA(200,DA(1),"USC1",DA,0),U,2)>0
- QUIT
- +2 ;Trigger date
- SET $PIECE(^VA(200,DA(1),"USC1",DA,0),U,2)=DT
- +3 DO UPDATE(200.05,2,DT)
- +4 ;
- SET2 ;Call from the X-ref on the Effective Date field
- +1 NEW L,REC
- +2 SET L=$ORDER(^VA(200,DA(1),"USC1",DA),-1)
- if L'>0
- QUIT
- +3 SET REC=^VA(200,DA(1),"USC1",L,0)
- +4 ;Inactivate the old one
- IF $PIECE(REC,U,3)=""
- DO OLD(DA(1),L,$$MAX^XLFMTH(X,$PIECE(REC,U,2)))
- +5 QUIT
- KILL2 ;Call from the X-ref on the Effective Date field
- +1 NEW L
- +2 SET L=$ORDER(^VA(200,DA(1),"USC1",DA),-1)
- if L'>0
- QUIT
- +3 IF $PIECE(^VA(200,DA(1),"USC1",L,0),U,3)=X
- DO OLD(DA(1),L,"")
- +4 QUIT
- +5 ;
- OLD(D0,D1,DATE) ;Inactivate the old one (Expiration Date)
- +1 NEW DA,X
- +2 ;Inactivate the old one
- SET $PIECE(^VA(200,D0,"USC1",D1,0),U,3)=DATE
- +3 SET DA(1)=D0
- SET DA=D1
- DO UPDATE(200.05,3,DATE)
- +4 QUIT
- UPDATE(DIH,DIG,DIV,DIU) ;file,field,new value,old value
- +1 SET DIV=$GET(DIV)
- SET DIU=$GET(DIU)
- SET DIV(0)=DA(1)
- SET DIV(1)=DA
- +2 if $ORDER(^DD(DIH,DIG,1,0))>0
- DO ^DICR
- +3 QUIT
- DDS1 ;Called from Pre-action person class field
- +1 NEW %,XUDA,XU
- +2 IF X]""
- SET %=^USC(8932.1,X,0)
- SET XU(1)=$PIECE(%,U,1)
- SET XU(2)=" "_$PIECE(%,U,2)
- SET XU(3)=" "_$PIECE(%,U,3)
- DO HLP^DDSUTL(.XU)
- +3 ;Hide DA
- if DA'>0
- QUIT
- MERGE XUDA=DA
- NEW DA
- +4 SET %=$$GET^DDSVAL(DIE,.XUDA,3,"","I")
- SET %=$SELECT(%>0:1,1:0)
- +5 DO UNED^DDSUTL(2,,,%)
- DO UNED^DDSUTL(3,,,%)
- +6 QUIT
- DDS2 ;Called from effective date on form
- +1 ;Hide DA
- NEW %,XUDA
- MERGE XUDA=DA
- NEW DA
- +2 SET XUDA=$ORDER(^VA(200,XUDA(1),"USC1",XUDA),-1)
- if XUDA'>0
- QUIT
- +3 ;Already has value
- SET %=$$GET^DDSVAL(DIE,.XUDA,3,"","I")
- if %&(%<X)
- QUIT
- +4 DO PUT^DDSVAL(DIE,.XUDA,3,X,"","I")
- +5 QUIT
- DDS3(%) ;Data validation
- +1 IF %=2
- IF $$GET^DDSVAL(DIE,.DA,3,"","I")]""
- Begin DoDot:1
- +2 SET DDSERROR=1
- +3 DO HLP^DDSUTL("This field is uneditable because Expired Date already has data")
- +4 QUIT
- End DoDot:1
- +5 IF %=3
- IF DDSOLD]""
- IF X'=DDSOLD
- Begin DoDot:1
- +6 SET DDSERROR=1
- +7 DO HLP^DDSUTL("You cannot change the value of this field.")
- +8 QUIT
- End DoDot:1
- +9 QUIT