ORY44B ; SLC/PKS-KR Remove Terminated Users (get DD info) ; [11/8/99 1:45pm]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**44**;Dec 17, 1997
Q
;
INFO(FILE,FIELD,ORA) ;
;
; DIC Global Root for <FILE>
; LOC Global Subscript Location (#;#) for <FIELD>
;
; INFO(<file #>,<field #>,.ARRAY)
;
; Returns
;
; ARRAY("DIC",0)=Global Root
; ARRAY("DIC",1)=File Root
; ARRAY("DIC",2)=Subfile Root
; ARRAY("DIC",..)=Subfile Root
; ARRAY("FILE")=Target File/Subfile Number
; ARRAY("FIELD")=Target Field
; ARRAY("NAME")=Target Field Name
; ARRAY("LOC")=Subscript and Piece
;
N DIC,LOC,SUB,SUBI,SFS,SNS S (DIC,LOC)="",FILE=+($G(FILE)),FIELD=+($G(FIELD))
Q:FILE=0!(FIELD=0) Q:'$D(^DD(FILE))
S ORA("FILE")=FILE,ORA("FIELD")=FIELD
D GETDD
S:$L(DIC) ORA("DIC",0)=$P(DIC,"(",1)_"(",ORA("DIC",1)=DIC
S:$L($G(SFS)) ORA("DIC",1,"P")=SFS
S:$L(LOC) ORA("LOC")=LOC
Q
GETDD ; Get file roots from DD
;
; FILE Current File #
; FIELD Current Field #
; DIC Current Global Root
; LOC Current Global Subscript Location (#;#)
; ARY( Temporay Storage Array (contains DD)
; ORA( Output Array
;
N ARY M ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
M ARY(FILE,0,"UP")=^DD(FILE,0,"UP")
S ORA("NAME")=$P($G(ARY(FILE,FIELD,0)),"^",1)
S:'$L($G(LOC))&($D(ARY(FILE,FIELD,0))) LOC=$P(ARY(FILE,FIELD,0),"^",4)
D CURRDD:'$D(ARY(FILE,0,"UP")),NEXTDD:$D(ARY(FILE,0,"UP"))
Q
CURRDD ; Current DD
;
; FILE Current File #
; DIC Current Global Root
; SFS Subfile Specifier Array
; ARY( Temporary Storage Array (contains DD)
;
S DIC=$$ROOT^DILFD(FILE,0,"GL")
S SFS=$P($$ROOT^DILFD(FILE,0),"^",2)
Q
NEXTDD ; Next DD Level (for subfiles)
;
; OLDFILE Previous File #
; OLDFIELD Previous Field #
; OLDDIC Previous Global Root
; OLDLOC Previous Global Subscript Location (#;#)
; FILE Current File #
; FIELD Current Field #
; DIC Current Global Root
; SNS Subfile Number and Subfile Specifier
; LOC Current Global Subscript Location (#;#)
; ARY( Temporay Storage Array (contains DD)
; ORA( Output Array
; SUB( Subscript Array
; SFS( Subfile Specifier Array
; SUBI Subscript Counter
; SS Subscript
; DA Internal Entry Number Array
; CT1 Miscellaneous Counter #1
; CT2 Miscellaneous Counter #2
;
N FILE2,FIELD2,DIC2,LOC2,CT1,CT2
S LOC2=LOC,(FILE2,FIELD2)=FILE N FILE,FIELD,DIC
S FILE=$G(ARY(FILE2,0,"UP"))
N ARY M ARY(FILE,"SB",FIELD2)=^DD(FILE,"SB",FIELD2)
S FIELD=$O(ARY(FILE,"SB",FILE2,0))
M ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
S SNS=$P($G(ARY(FILE,FIELD,0)),"^",2)
S SUBI=+($O(SUB(" "),-1)),SUBI=SUBI+1
S SUB(SUBI)=$P($P($G(ARY(FILE,FIELD,0)),"^",4),";",1),DIC=""
S SFS(SUBI)=SNS
D GETDD
S LOC=LOC2 I $L(DIC) D
. S ORA("DIC",0)=$P(DIC,"(",1)_"(",ORA("DIC",1)=DIC
. N DA,SS F CT1=SUBI:-1:1 S DA="DA("_CT1_")",DIC=DIC_DA_"," D
. . F CT2=SUBI:-1:1 D
. . . S SS=$G(SUB(CT2)),DIC=DIC_SS_",",ORA("DIC",(CT2+1))=DIC S:$L($G(SFS(CT2))) ORA("DIC",(CT2+1),"P")=$G(SFS(CT2))
Q
;
TERM(X) ; Terminated
;
; Returns: Status^Explanation -
;
; 2 = Terminated
; 1 = Future Termination
; 0 = Not Terminated
; -1 = Error^Error Text
;
; USR New Person
; NAM New Person Name
; NOW Today's Date
; % Fileman Date and Time
; %I( Fileman Date Array
; %H $H Date and Time
; X Today
; ORLPERR Error Array
; ORLPUSR New Person Holder
;
N USR,USRITD,NAM,NOW,%,%I,%H,ORLPERR,ORLPUSR S USR=+($G(X)) Q:USR=0 "-1^Invalid User"
Q:'$D(^VA(200,+USR,0)) "-1^User not found"
Q:'$L($P($G(^VA(200,+USR,0)),"^",1)) "-1^Invalid User (no name)"
S NAM=$P($G(^VA(200,+USR,0)),"^",1)
D NOW^%DTC S NOW=X
S ORLPUSR=USR
S USRITD=$$GET1^DIQ(200,ORLPUSR,9.2,"I",,.ORLPERR) Q:$D(ORLPERR) "-1^Invalid User"
Q:USRITD="" ("0^User ("_NAM_") is an active user")
Q:+USRITD=0 ("0^User ("_NAM_") is an active user")
Q:+USRITD'>NOW ("2^User ("_NAM_") has been terminated")
Q:+USRITD<NOW ("1^User ("_NAM_") will be terminated on "_$$FMTE^XLFDT(USRITD))
Q "-1^Undetermined"
;
ORY44B ; SLC/PKS-KR Remove Terminated Users (get DD info) ; [11/8/99 1:45pm]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**44**;Dec 17, 1997
+2 QUIT
+3 ;
INFO(FILE,FIELD,ORA) ;
+1 ;
+2 ; DIC Global Root for <FILE>
+3 ; LOC Global Subscript Location (#;#) for <FIELD>
+4 ;
+5 ; INFO(<file #>,<field #>,.ARRAY)
+6 ;
+7 ; Returns
+8 ;
+9 ; ARRAY("DIC",0)=Global Root
+10 ; ARRAY("DIC",1)=File Root
+11 ; ARRAY("DIC",2)=Subfile Root
+12 ; ARRAY("DIC",..)=Subfile Root
+13 ; ARRAY("FILE")=Target File/Subfile Number
+14 ; ARRAY("FIELD")=Target Field
+15 ; ARRAY("NAME")=Target Field Name
+16 ; ARRAY("LOC")=Subscript and Piece
+17 ;
+18 NEW DIC,LOC,SUB,SUBI,SFS,SNS
SET (DIC,LOC)=""
SET FILE=+($GET(FILE))
SET FIELD=+($GET(FIELD))
+19 IF FILE=0!(FIELD=0)
QUIT
IF '$DATA(^DD(FILE))
QUIT
+20 SET ORA("FILE")=FILE
SET ORA("FIELD")=FIELD
+21 DO GETDD
+22 IF $LENGTH(DIC)
SET ORA("DIC",0)=$PIECE(DIC,"(",1)_"("
SET ORA("DIC",1)=DIC
+23 IF $LENGTH($GET(SFS))
SET ORA("DIC",1,"P")=SFS
+24 IF $LENGTH(LOC)
SET ORA("LOC")=LOC
+25 QUIT
GETDD ; Get file roots from DD
+1 ;
+2 ; FILE Current File #
+3 ; FIELD Current Field #
+4 ; DIC Current Global Root
+5 ; LOC Current Global Subscript Location (#;#)
+6 ; ARY( Temporay Storage Array (contains DD)
+7 ; ORA( Output Array
+8 ;
+9 NEW ARY
MERGE ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
+10 MERGE ARY(FILE,0,"UP")=^DD(FILE,0,"UP")
+11 SET ORA("NAME")=$PIECE($GET(ARY(FILE,FIELD,0)),"^",1)
+12 IF '$LENGTH($GET(LOC))&($DATA(ARY(FILE,FIELD,0)))
SET LOC=$PIECE(ARY(FILE,FIELD,0),"^",4)
+13 IF '$DATA(ARY(FILE,0,"UP"))
DO CURRDD
IF $DATA(ARY(FILE,0,"UP"))
DO NEXTDD
+14 QUIT
CURRDD ; Current DD
+1 ;
+2 ; FILE Current File #
+3 ; DIC Current Global Root
+4 ; SFS Subfile Specifier Array
+5 ; ARY( Temporary Storage Array (contains DD)
+6 ;
+7 SET DIC=$$ROOT^DILFD(FILE,0,"GL")
+8 SET SFS=$PIECE($$ROOT^DILFD(FILE,0),"^",2)
+9 QUIT
NEXTDD ; Next DD Level (for subfiles)
+1 ;
+2 ; OLDFILE Previous File #
+3 ; OLDFIELD Previous Field #
+4 ; OLDDIC Previous Global Root
+5 ; OLDLOC Previous Global Subscript Location (#;#)
+6 ; FILE Current File #
+7 ; FIELD Current Field #
+8 ; DIC Current Global Root
+9 ; SNS Subfile Number and Subfile Specifier
+10 ; LOC Current Global Subscript Location (#;#)
+11 ; ARY( Temporay Storage Array (contains DD)
+12 ; ORA( Output Array
+13 ; SUB( Subscript Array
+14 ; SFS( Subfile Specifier Array
+15 ; SUBI Subscript Counter
+16 ; SS Subscript
+17 ; DA Internal Entry Number Array
+18 ; CT1 Miscellaneous Counter #1
+19 ; CT2 Miscellaneous Counter #2
+20 ;
+21 NEW FILE2,FIELD2,DIC2,LOC2,CT1,CT2
+22 SET LOC2=LOC
SET (FILE2,FIELD2)=FILE
NEW FILE,FIELD,DIC
+23 SET FILE=$GET(ARY(FILE2,0,"UP"))
+24 NEW ARY
MERGE ARY(FILE,"SB",FIELD2)=^DD(FILE,"SB",FIELD2)
+25 SET FIELD=$ORDER(ARY(FILE,"SB",FILE2,0))
+26 MERGE ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
+27 SET SNS=$PIECE($GET(ARY(FILE,FIELD,0)),"^",2)
+28 SET SUBI=+($ORDER(SUB(" "),-1))
SET SUBI=SUBI+1
+29 SET SUB(SUBI)=$PIECE($PIECE($GET(ARY(FILE,FIELD,0)),"^",4),";",1)
SET DIC=""
+30 SET SFS(SUBI)=SNS
+31 DO GETDD
+32 SET LOC=LOC2
IF $LENGTH(DIC)
Begin DoDot:1
+33 SET ORA("DIC",0)=$PIECE(DIC,"(",1)_"("
SET ORA("DIC",1)=DIC
+34 NEW DA,SS
FOR CT1=SUBI:-1:1
SET DA="DA("_CT1_")"
SET DIC=DIC_DA_","
Begin DoDot:2
+35 FOR CT2=SUBI:-1:1
Begin DoDot:3
+36 SET SS=$GET(SUB(CT2))
SET DIC=DIC_SS_","
SET ORA("DIC",(CT2+1))=DIC
IF $LENGTH($GET(SFS(CT2)))
SET ORA("DIC",(CT2+1),"P")=$GET(SFS(CT2))
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT
+38 ;
TERM(X) ; Terminated
+1 ;
+2 ; Returns: Status^Explanation -
+3 ;
+4 ; 2 = Terminated
+5 ; 1 = Future Termination
+6 ; 0 = Not Terminated
+7 ; -1 = Error^Error Text
+8 ;
+9 ; USR New Person
+10 ; NAM New Person Name
+11 ; NOW Today's Date
+12 ; % Fileman Date and Time
+13 ; %I( Fileman Date Array
+14 ; %H $H Date and Time
+15 ; X Today
+16 ; ORLPERR Error Array
+17 ; ORLPUSR New Person Holder
+18 ;
+19 NEW USR,USRITD,NAM,NOW,%,%I,%H,ORLPERR,ORLPUSR
SET USR=+($GET(X))
IF USR=0
QUIT "-1^Invalid User"
+20 IF '$DATA(^VA(200,+USR,0))
QUIT "-1^User not found"
+21 IF '$LENGTH($PIECE($GET(^VA(200,+USR,0)),"^",1))
QUIT "-1^Invalid User (no name)"
+22 SET NAM=$PIECE($GET(^VA(200,+USR,0)),"^",1)
+23 DO NOW^%DTC
SET NOW=X
+24 SET ORLPUSR=USR
+25 SET USRITD=$$GET1^DIQ(200,ORLPUSR,9.2,"I",,.ORLPERR)
IF $DATA(ORLPERR)
QUIT "-1^Invalid User"
+26 IF USRITD=""
QUIT ("0^User ("_NAM_") is an active user")
+27 IF +USRITD=0
QUIT ("0^User ("_NAM_") is an active user")
+28 IF +USRITD'>NOW
QUIT ("2^User ("_NAM_") has been terminated")
+29 IF +USRITD<NOW
QUIT ("1^User ("_NAM_") will be terminated on "_$$FMTE^XLFDT(USRITD))
+30 QUIT "-1^Undetermined"
+31 ;
