- 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 ;