- 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 Jan 18, 2025@03:29:16 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 ;