PSUTL ;BIR/PDW - Utilities for AR/WS extracts ;12 AUG 1999
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
; Reference to DOLRO^%ZOSV supported by DBIA 2500
;
; Entry Points
;
; D GETS^PSUTL(,,,,)
; D GETM^PSUTL(,,,,)
; $$VAL^PSUTL(,,)
; $$VALI^PSUTL(,,)
; ---------------------
; D MOVEI^PSUTL("ref") Moves @ref@(Fld,"I") Value to (Fld) node
; D MOVEMI^PSUTL("ref") Moves @ref@(da,Fld,"I") value to (da,Fld) node
; ---------------------
; ---------------------
; Details & Parameters
; D GETS^PSUTL(,,,,) Returns @root@(Field Number(s)) = Value(s)
; Multiples NO
;
; D GETM^PSUTL(,,,,) Returns @root@(DA,Field Number(s)) = Value(s)
; Multiples YES & ONLY
;
; S X=$$VAL^PSUTL(,,) X = External Value
; S X=$$VALI^PSUTL(,,) X = Interanl Value
;
; [ Variables for Parameter Passing ]
; PSUFILE = file number or subfile number as described in GETS^DIQ()
; PSUDA = List or array of IENS NOT as described in GETS^DIQ()
;
; A .DA array or a list of IENS left to right as they are in the
; global data arrays D0,D1,D2 as within a FM Global map
; This Iens list can be constructed with variables.
; Example: as reaching into file 200 division subfile 200.02
; "DUZ,SITE"
;
; PSUDR = DR string as described in GETS^DIQ()
; PSUROOT = closed array as described in GETS^DIQ()
; PSUFORM = format control as described in GETS^DIQ()
;
GETS(PSUFILE,PSUDA,PSUDR,PSUROOT,PSUFORM) ;
; Example S PSUSITE=6025
; D GETS^PSUTL(200.02,"DUZ,PSUSITE",".01","DIV")
; returns
; DIV(.01)="HINES DEVELOPMENT"
;
N PSUIEN,DA
I $D(PSUFILE),$D(PSUDA),$D(PSUDR),$D(PSUROOT)
E Q
I '$D(PSUFORM) S PSUFORM=""
D PARSE(PSUDA)
S PSUIEN=$$IENS^DILF(.DA)
K ^TMP("PSUDIQ",$J)
D GETS^DIQ(PSUFILE,PSUIEN,PSUDR,PSUFORM,"^TMP(""PSUDIQ"",$J)")
;
I $G(PSUMTUL) Q
;
M @PSUROOT=^TMP("PSUDIQ",$J,PSUFILE,PSUIEN)
K ^TMP("PSUDIQ",$J)
Q
;
VAL(PSUFILE,PSUDA,PSUFLD) ; Returns External Value
N PSUTMP
I $D(PSUFILE),$D(PSUDA),$D(PSUFLD)
E Q ""
D GETS(PSUFILE,PSUDA,PSUFLD,"PSUTMP")
Q $G(PSUTMP(PSUFLD))
VALI(PSUFILE,PSUDA,PSUFLD) ; Returns Internal Value
N PSUTMP
I $D(PSUFILE),$D(PSUDA),$D(PSUFLD)
E Q ""
D GETS(PSUFILE,PSUDA,PSUFLD,"PSUTMP","I")
Q $G(PSUTMP(PSUFLD,"I"))
;
GETM(PSUFILE,PSUDA,PSUFLD,PSUROOT,PSUFORM) ;EP RETURN MULTIPLES
; PSUFILE is the immediate upper level file number of the one desired
; PSUDA is the "DO,D1,Dx .." IENS to get to the immediate upper level
; PSUFLD is the field notation for the multiple at the upper level
; "3*"
; appended with "^" and the list of fields ".01;.02;9.3;..."
; resulting in "3*^.01;.02;9.3;..."
; PSUROOT is the target closed array reference
; PSUFORM is the format as in GET^DIQ
; return form is @PSUROOT@(da,fld)=VALUE
;
; example: pulls multiple divisions from file 200
; D GETM^PSUTL(200,DUZ,"16*^.01","DIV")
; Returns DIV(578,.01) ="HINES, IL"
; DIV(6020,.01)="HINES ISC"
; DIV(6025,.01)="HINES DEVELOPMENT"
;
N PSUMTUL,PSUSUB,PSUDID
I $D(PSUFILE),$D(PSUDA),$D(PSUFLD),$D(PSUROOT)
E Q
S PSUMTUL=1
I '$D(PSUFORM) S PSUFORM=""
I PSUFLD'["^" Q
K PSUFLDL
S PSUFLDL=$P(PSUFLD,U,2),PSUFLD=$P(PSUFLD,U)
I +PSUFLDL,+PSUFLD
E Q
D FIELD^DID(PSUFILE,+PSUFLD,"","SPECIFIER","PSUDID")
S PSUSUB=+PSUDID("SPECIFIER")
D GETS(PSUFILE,PSUDA,PSUFLD,PSUROOT,PSUFORM)
; load multiple into target array
S PSUIEN=0 F S PSUIEN=$O(^TMP("PSUDIQ",$J,PSUSUB,PSUIEN)) Q:+PSUIEN'>0 M @PSUROOT@(+PSUIEN)=^TMP("PSUDIQ",$J,PSUSUB,PSUIEN)
K ^TMP("PSUDIQ",$J)
Q:'$D(PSUFLDL)
;
; process individual fields
N I,FLD
S FLD=+PSUFLDL,PSUFLDL(FLD)=0
F I=2:1 S FLD=$P(PSUFLDL,";",I) Q:FLD'>0 S PSUFLDL(FLD)=""
S PSUIEN=0 F S PSUIEN=$O(@PSUROOT@(PSUIEN)) Q:PSUIEN'>0 D
. S FLD=0
. F S FLD=$O(@PSUROOT@(PSUIEN,FLD)) Q:FLD'>0 I '$D(PSUFLDL(FLD)) K @PSUROOT@(PSUIEN,FLD)
K PSUFLDL
Q
PARSE(XBDA) ;PEP - parse DA literal into da array
I XBDA="",$D(XBDA)=1 S DA=0 Q
NEW D,I,J
F I=1:1 S D(I)=$P(XBDA,",",I) Q:D(I)=""
S I=I-1
F J=0:1:I-1 S DA(J)=D(I-J)
F J=0:1:I-1 F Q:(DA(J)=+DA(J)) S DA(J)=@(DA(J)) S:DA(J)="" DA(J)=0
S DA=DA(0)
KILL DA(0)
Q
MOVEI(PSUREF) ;EP Move @PSUREF@(Fld,"I") values to @PSUREF@(Fld)
N PSUFLD
S PSUFLD=0 F S PSUFLD=$O(@PSUREF@(PSUFLD)) Q:PSUFLD'>0 S @PSUREF@(PSUFLD)=$G(@PSUREF@(PSUFLD,"I")) K @PSUREF@(PSUFLD,"I")
Q
;
MOVEMI(PSUREF) ;EP Move @PSUREF@(da,Fld,"I") values to @PSUREF@(da,Fld)
N PSUDA,PSUFLD
S PSUDA=0 F S PSUDA=$O(@PSUREF@(PSUDA)) Q:PSUDA'>0 D
. S PSUFLD=0 F S PSUFLD=$O(@PSUREF@(PSUDA,PSUFLD)) Q:PSUFLD'>0 S @PSUREF@(PSUDA,PSUFLD)=@PSUREF@(PSUDA,PSUFLD,"I") K @PSUREF@(PSUDA,PSUFLD,"I")
Q
;
UPPER(PSUX) ;Convert lower case to upper case
Q $TR(PSUX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
VARKILL ;PEP Kill variable PSU* namespace
;Kills off all PSU Variables
S X="^TMP(""PSUVAR"",$J,"
D DOLRO^%ZOSV ; load symbols into ^TMP(,,var)=..
; (preserve PSU,PSUXMY*)
S X="" F S X=$O(^TMP("PSUVAR",$J,X)) Q:X="" I $E(X,1,3)="PSU",X'="PSU",($E(X,1,6)'="PSUXMY"),X'="PSUJOB" K @X
K ^TMP("PSUVAR",$J)
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUTL 5285 printed Sep 23, 2025@20:04:13 Page 2
PSUTL ;BIR/PDW - Utilities for AR/WS extracts ;12 AUG 1999
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ; Reference to DOLRO^%ZOSV supported by DBIA 2500
+4 ;
+5 ; Entry Points
+6 ;
+7 ; D GETS^PSUTL(,,,,)
+8 ; D GETM^PSUTL(,,,,)
+9 ; $$VAL^PSUTL(,,)
+10 ; $$VALI^PSUTL(,,)
+11 ; ---------------------
+12 ; D MOVEI^PSUTL("ref") Moves @ref@(Fld,"I") Value to (Fld) node
+13 ; D MOVEMI^PSUTL("ref") Moves @ref@(da,Fld,"I") value to (da,Fld) node
+14 ; ---------------------
+15 ; ---------------------
+16 ; Details & Parameters
+17 ; D GETS^PSUTL(,,,,) Returns @root@(Field Number(s)) = Value(s)
+18 ; Multiples NO
+19 ;
+20 ; D GETM^PSUTL(,,,,) Returns @root@(DA,Field Number(s)) = Value(s)
+21 ; Multiples YES & ONLY
+22 ;
+23 ; S X=$$VAL^PSUTL(,,) X = External Value
+24 ; S X=$$VALI^PSUTL(,,) X = Interanl Value
+25 ;
+26 ; [ Variables for Parameter Passing ]
+27 ; PSUFILE = file number or subfile number as described in GETS^DIQ()
+28 ; PSUDA = List or array of IENS NOT as described in GETS^DIQ()
+29 ;
+30 ; A .DA array or a list of IENS left to right as they are in the
+31 ; global data arrays D0,D1,D2 as within a FM Global map
+32 ; This Iens list can be constructed with variables.
+33 ; Example: as reaching into file 200 division subfile 200.02
+34 ; "DUZ,SITE"
+35 ;
+36 ; PSUDR = DR string as described in GETS^DIQ()
+37 ; PSUROOT = closed array as described in GETS^DIQ()
+38 ; PSUFORM = format control as described in GETS^DIQ()
+39 ;
GETS(PSUFILE,PSUDA,PSUDR,PSUROOT,PSUFORM) ;
+1 ; Example S PSUSITE=6025
+2 ; D GETS^PSUTL(200.02,"DUZ,PSUSITE",".01","DIV")
+3 ; returns
+4 ; DIV(.01)="HINES DEVELOPMENT"
+5 ;
+6 NEW PSUIEN,DA
+7 IF $DATA(PSUFILE)
IF $DATA(PSUDA)
IF $DATA(PSUDR)
IF $DATA(PSUROOT)
+8 IF '$TEST
QUIT
+9 IF '$DATA(PSUFORM)
SET PSUFORM=""
+10 DO PARSE(PSUDA)
+11 SET PSUIEN=$$IENS^DILF(.DA)
+12 KILL ^TMP("PSUDIQ",$JOB)
+13 DO GETS^DIQ(PSUFILE,PSUIEN,PSUDR,PSUFORM,"^TMP(""PSUDIQ"",$J)")
+14 ;
+15 IF $GET(PSUMTUL)
QUIT
+16 ;
+17 MERGE @PSUROOT=^TMP("PSUDIQ",$JOB,PSUFILE,PSUIEN)
+18 KILL ^TMP("PSUDIQ",$JOB)
+19 QUIT
+20 ;
VAL(PSUFILE,PSUDA,PSUFLD) ; Returns External Value
+1 NEW PSUTMP
+2 IF $DATA(PSUFILE)
IF $DATA(PSUDA)
IF $DATA(PSUFLD)
+3 IF '$TEST
QUIT ""
+4 DO GETS(PSUFILE,PSUDA,PSUFLD,"PSUTMP")
+5 QUIT $GET(PSUTMP(PSUFLD))
VALI(PSUFILE,PSUDA,PSUFLD) ; Returns Internal Value
+1 NEW PSUTMP
+2 IF $DATA(PSUFILE)
IF $DATA(PSUDA)
IF $DATA(PSUFLD)
+3 IF '$TEST
QUIT ""
+4 DO GETS(PSUFILE,PSUDA,PSUFLD,"PSUTMP","I")
+5 QUIT $GET(PSUTMP(PSUFLD,"I"))
+6 ;
GETM(PSUFILE,PSUDA,PSUFLD,PSUROOT,PSUFORM) ;EP RETURN MULTIPLES
+1 ; PSUFILE is the immediate upper level file number of the one desired
+2 ; PSUDA is the "DO,D1,Dx .." IENS to get to the immediate upper level
+3 ; PSUFLD is the field notation for the multiple at the upper level
+4 ; "3*"
+5 ; appended with "^" and the list of fields ".01;.02;9.3;..."
+6 ; resulting in "3*^.01;.02;9.3;..."
+7 ; PSUROOT is the target closed array reference
+8 ; PSUFORM is the format as in GET^DIQ
+9 ; return form is @PSUROOT@(da,fld)=VALUE
+10 ;
+11 ; example: pulls multiple divisions from file 200
+12 ; D GETM^PSUTL(200,DUZ,"16*^.01","DIV")
+13 ; Returns DIV(578,.01) ="HINES, IL"
+14 ; DIV(6020,.01)="HINES ISC"
+15 ; DIV(6025,.01)="HINES DEVELOPMENT"
+16 ;
+17 NEW PSUMTUL,PSUSUB,PSUDID
+18 IF $DATA(PSUFILE)
IF $DATA(PSUDA)
IF $DATA(PSUFLD)
IF $DATA(PSUROOT)
+19 IF '$TEST
QUIT
+20 SET PSUMTUL=1
+21 IF '$DATA(PSUFORM)
SET PSUFORM=""
+22 IF PSUFLD'["^"
QUIT
+23 KILL PSUFLDL
+24 SET PSUFLDL=$PIECE(PSUFLD,U,2)
SET PSUFLD=$PIECE(PSUFLD,U)
+25 IF +PSUFLDL
IF +PSUFLD
+26 IF '$TEST
QUIT
+27 DO FIELD^DID(PSUFILE,+PSUFLD,"","SPECIFIER","PSUDID")
+28 SET PSUSUB=+PSUDID("SPECIFIER")
+29 DO GETS(PSUFILE,PSUDA,PSUFLD,PSUROOT,PSUFORM)
+30 ; load multiple into target array
+31 SET PSUIEN=0
FOR
SET PSUIEN=$ORDER(^TMP("PSUDIQ",$JOB,PSUSUB,PSUIEN))
if +PSUIEN'>0
QUIT
MERGE @PSUROOT@(+PSUIEN)=^TMP("PSUDIQ",$JOB,PSUSUB,PSUIEN)
+32 KILL ^TMP("PSUDIQ",$JOB)
+33 if '$DATA(PSUFLDL)
QUIT
+34 ;
+35 ; process individual fields
+36 NEW I,FLD
+37 SET FLD=+PSUFLDL
SET PSUFLDL(FLD)=0
+38 FOR I=2:1
SET FLD=$PIECE(PSUFLDL,";",I)
if FLD'>0
QUIT
SET PSUFLDL(FLD)=""
+39 SET PSUIEN=0
FOR
SET PSUIEN=$ORDER(@PSUROOT@(PSUIEN))
if PSUIEN'>0
QUIT
Begin DoDot:1
+40 SET FLD=0
+41 FOR
SET FLD=$ORDER(@PSUROOT@(PSUIEN,FLD))
if FLD'>0
QUIT
IF '$DATA(PSUFLDL(FLD))
KILL @PSUROOT@(PSUIEN,FLD)
End DoDot:1
+42 KILL PSUFLDL
+43 QUIT
PARSE(XBDA) ;PEP - parse DA literal into da array
+1 IF XBDA=""
IF $DATA(XBDA)=1
SET DA=0
QUIT
+2 NEW D,I,J
+3 FOR I=1:1
SET D(I)=$PIECE(XBDA,",",I)
if D(I)=""
QUIT
+4 SET I=I-1
+5 FOR J=0:1:I-1
SET DA(J)=D(I-J)
+6 FOR J=0:1:I-1
FOR
if (DA(J)=+DA(J))
QUIT
SET DA(J)=@(DA(J))
if DA(J)=""
SET DA(J)=0
+7 SET DA=DA(0)
+8 KILL DA(0)
+9 QUIT
MOVEI(PSUREF) ;EP Move @PSUREF@(Fld,"I") values to @PSUREF@(Fld)
+1 NEW PSUFLD
+2 SET PSUFLD=0
FOR
SET PSUFLD=$ORDER(@PSUREF@(PSUFLD))
if PSUFLD'>0
QUIT
SET @PSUREF@(PSUFLD)=$GET(@PSUREF@(PSUFLD,"I"))
KILL @PSUREF@(PSUFLD,"I")
+3 QUIT
+4 ;
MOVEMI(PSUREF) ;EP Move @PSUREF@(da,Fld,"I") values to @PSUREF@(da,Fld)
+1 NEW PSUDA,PSUFLD
+2 SET PSUDA=0
FOR
SET PSUDA=$ORDER(@PSUREF@(PSUDA))
if PSUDA'>0
QUIT
Begin DoDot:1
+3 SET PSUFLD=0
FOR
SET PSUFLD=$ORDER(@PSUREF@(PSUDA,PSUFLD))
if PSUFLD'>0
QUIT
SET @PSUREF@(PSUDA,PSUFLD)=@PSUREF@(PSUDA,PSUFLD,"I")
KILL @PSUREF@(PSUDA,PSUFLD,"I")
End DoDot:1
+4 QUIT
+5 ;
UPPER(PSUX) ;Convert lower case to upper case
+1 QUIT $TRANSLATE(PSUX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
VARKILL ;PEP Kill variable PSU* namespace
+1 ;Kills off all PSU Variables
+2 SET X="^TMP(""PSUVAR"",$J,"
+3 ; load symbols into ^TMP(,,var)=..
DO DOLRO^%ZOSV
+4 ; (preserve PSU,PSUXMY*)
+5 SET X=""
FOR
SET X=$ORDER(^TMP("PSUVAR",$JOB,X))
if X=""
QUIT
IF $EXTRACT(X,1,3)="PSU"
IF X'="PSU"
IF ($EXTRACT(X,1,6)'="PSUXMY")
IF X'="PSUJOB"
KILL @X
+6 KILL ^TMP("PSUVAR",$JOB)
+7 ;
+8 ;
