PRPFU2 ;VAMC ALTOONA/CTB - MISC UTILITY ROUTINES ;11/22/96 4:48 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
;ENTRY TO PLACE VALUES OF FIELDS INTO VARIABLES
;REQUIRES INPUT OF DIC, DA, DR, X
;DIC = FILE NUMBER OR GLOBAL ROOT
;DA = INTERNAL RECORD NUMBER
;DR = LIST OF FIELD NUMBERS DELIMITED WITH ';'
;X = LIST OF VARIABLE NAMES MAPPED TO FIELDS IN DR
; NOTE VARIABLE NAME ALONE IMPLIES EXTERNAL
; IF BOTH INTERNAL AND EXTERNAL VALUES ARE REQUIRED, ';' PIECE
; SHOULD BE "VNAME,I,VNAME2,E;" OR "VNAME,,VNAME2,I;
;DIQ OPTIONAL VARIABLE CONTAINING GLOBAL ROOT IE ^TMP( . STORE
; ERROR COULD OCCUR FOR EXTREMELY LONG EXTRACTIONS. SETTING
; DIQ WILL FORCE PROGRAM TO PLACE DATA IN GLOBAL
;USES VARIABLE ARRAY TMP FOR TEMPORARY STORAGE UNLESS OVERRIDEN BY
; GLOBAL ROOT IN DIQ
EXT(DIC,DA,DR,X,DIQ) ;
EN1 N TMP,I,FN,FNX,ZX,ZY,N,DAX,DRX,D0,S,C
S ZX=X I $O(X(0)) S N=0 F S N=$O(X(N)) Q:'N S ZX(N)=X(N)
S U="^",DIQ(0)=$S(X[",I":"EI",1:"E") S:$G(DIQ)="" DIQ="TMP("
D EN^DIQ1
S FN=+$P($G(@(DIC_"0)")),"^",2) Q:'FN
I $O(DA(0)) S N=0 F S N=$O(DA(N)) Q:'N S FN(N)=N
F I=1:1 Q:$P(ZX,";",I)="" D
. S ZY=$P(ZX,";",I)
. Q:ZY=""
. S S=";",C="," X "S "_$P(ZY,",")_"=$G("_DIQ_"FN,DA,$P(DR,S,I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
. I $P(ZY,",",3)]"" S ZY=$P(ZY,",",3,4) X "S "_$P(ZY,",")_"=$G("_DIQ_"FN,DA,$P(DR,S,I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
. Q
I $O(FN(0)) S N=0 F S N=$O(FN(N)) Q:'N D
. Q:FN(N)="" S FNX=FN(N)
. Q:($G(DR(FNX))="")!($G(DA(FNX))="")!($G(ZX(FNX))="")
. S ZX=ZX(FNX),FNX=FN(N),DAX=DA(FNX),DRX=DR(FNX)
. F I=1:1 Q:$P(ZX,";",I)="" D
. . S ZY=$P(ZX,";",I)
. . Q:ZY=""
. . X "S "_$P(ZY,",")_"=$G("_DIQ_"FNX,DAX,$P(DRX,"";"",I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
. . I $P(ZY,",",3)]"" S ZY=$P(ZY,",",3,4) X "S "_$P(ZY,",")_"=$G("_DIQ_"FNX,DAX,$P(DRX,"";"",I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
. . Q
I $E(DIQ,$L(DIQ))="," K @($E(DIQ,$L(DIQ)-1)_")")
I $E(DIQ,$L(DIQ))="(" K @($E(DIQ,$L(DIQ)-1))
Q
LZF(STRING,LENGTH) ;LEFT ZERO FILL STRING IN A FIELD LENGTH OF LENGTH
N X
S $P(X,"0",LENGTH)="0",STRING=X_STRING
Q $E(STRING,$L(STRING)-(LENGTH-1),$L(STRING))
RZF(STRING,LENGTH) ;RIGHT ZERO FILL STRING IN A FIELD LENGTH OF LENGTH
N X
S $P(X,"0",LENGTH)=0,STRING=STRING_X
Q $E(STRING,1,LENGTH)
LBF(STRING,LENGTH) ;LEFT BLANK FILL STRING IN A FIELD LENGTH OF LENGTH
N X
S $P(X," ",LENGTH)=" ",STRING=X_STRING
Q $E(STRING,$L(STRING)-(LENGTH-1),$L(STRING))
RBF(STRING,LENGTH) ;RIGHT BLANK FILL STRING IN A FIELD LENGTH OF LENGTH
N X
S $P(X," ",LENGTH)=" ",STRING=STRING_X
Q $E(STRING,1,LENGTH)
DIR() ;SET VARIABLE STRING RETURNING FROM DIR
NEW X
S X=$D(DTOUT)_$D(DUOUT)_$D(DIRUT)_$D(DIROUT)
K DTOUT,DUOUT,DIRUT,DIROUT
Q X
;
FULLDAT(Y) ;CONVERTS FILEMAN INTERNAL DATE TO EXTERNAL FORMAT
S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".")
Q Y
;
EXTSSN(X) ;RETURNS EXTERNAL VALUE OF SSN
I X'?9N Q X
Q $E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,9)
;
LOWER(X) ;RETURNS STRING X IN LOWER CASE
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UPPER(X) ;RETURNS STRING X IN UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
AGE(X2,X1) ;extrinsic function returns current age based on date X
N %,%H,%I,%T,X,%Y
I $G(X1)="" D NOW^%DTC S X1=X
D ^%DTC
Q X\365.25
SETOFCDS ;display set of codes
N X,LN,Y
Q:$P($G(DIR(0)),"^",1)'["S"
W !,"Select From:",!
S X=$P(DIR(0),"^",2)
F LN=1:1 Q:$P(X,";",LN)="" S Y=$P(X,";",LN) W !?5,$P(Y,":"),?15,$P(Y,":",2)
QUIT
;
VPHONE(X) ;extrinsic function, for validating telephone numbers
NEW PRPFX
I X="" Q 0
I X?7N Q 1
I X?3N1"-"4N Q 1
I X?10N Q 1
I X?3N1"-"3N1"-"4N Q 1
I X?7N1" ".6UN Q 1
I X?3N1"-"4N1" ".6UN Q 1
I X?10N1" ".6UN Q 1
I X?3N1"-"3N1"-"4N1" ".6UN Q 1
Q 0
PHONEOUT(X) ;extrinsic function to print phone number
I $E(X,1,10)?10N Q $E(X,1,3)_"-"_$E(X,4,6)_"-"_$E(X,7,99)
I $E(X,1,7)?7N Q " "_$E(X,1,3)_"-"_$E(X,4,99)
I X?10N1" ".6UN Q $E(X,1,3)_"-"_$E(X,4,6)_"-"_$E(X,7,99)
I X?3N1"-"4N Q " "_X
I X?3N1"-"4N.1" ".6UN Q " "_X
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFU2 4320 printed Apr 09, 2024@21:04:22 Page 2
PRPFU2 ;VAMC ALTOONA/CTB - MISC UTILITY ROUTINES ;11/22/96 4:48 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
+1 ;ENTRY TO PLACE VALUES OF FIELDS INTO VARIABLES
+2 ;REQUIRES INPUT OF DIC, DA, DR, X
+3 ;DIC = FILE NUMBER OR GLOBAL ROOT
+4 ;DA = INTERNAL RECORD NUMBER
+5 ;DR = LIST OF FIELD NUMBERS DELIMITED WITH ';'
+6 ;X = LIST OF VARIABLE NAMES MAPPED TO FIELDS IN DR
+7 ; NOTE VARIABLE NAME ALONE IMPLIES EXTERNAL
+8 ; IF BOTH INTERNAL AND EXTERNAL VALUES ARE REQUIRED, ';' PIECE
+9 ; SHOULD BE "VNAME,I,VNAME2,E;" OR "VNAME,,VNAME2,I;
+10 ;DIQ OPTIONAL VARIABLE CONTAINING GLOBAL ROOT IE ^TMP( . STORE
+11 ; ERROR COULD OCCUR FOR EXTREMELY LONG EXTRACTIONS. SETTING
+12 ; DIQ WILL FORCE PROGRAM TO PLACE DATA IN GLOBAL
+13 ;USES VARIABLE ARRAY TMP FOR TEMPORARY STORAGE UNLESS OVERRIDEN BY
+14 ; GLOBAL ROOT IN DIQ
EXT(DIC,DA,DR,X,DIQ) ;
EN1 NEW TMP,I,FN,FNX,ZX,ZY,N,DAX,DRX,D0,S,C
+1 SET ZX=X
IF $ORDER(X(0))
SET N=0
FOR
SET N=$ORDER(X(N))
if 'N
QUIT
SET ZX(N)=X(N)
+2 SET U="^"
SET DIQ(0)=$SELECT(X[",I":"EI",1:"E")
if $GET(DIQ)=""
SET DIQ="TMP("
+3 DO EN^DIQ1
+4 SET FN=+$PIECE($GET(@(DIC_"0)")),"^",2)
if 'FN
QUIT
+5 IF $ORDER(DA(0))
SET N=0
FOR
SET N=$ORDER(DA(N))
if 'N
QUIT
SET FN(N)=N
+6 FOR I=1:1
if $PIECE(ZX,";",I)=""
QUIT
Begin DoDot:1
+7 SET ZY=$PIECE(ZX,";",I)
+8 if ZY=""
QUIT
+9 SET S=";"
SET C=","
XECUTE "S "_$PIECE(ZY,",")_"=$G("_DIQ_"FN,DA,$P(DR,S,I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
+10 IF $PIECE(ZY,",",3)]""
SET ZY=$PIECE(ZY,",",3,4)
XECUTE "S "_$PIECE(ZY,",")_"=$G("_DIQ_"FN,DA,$P(DR,S,I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
+11 QUIT
End DoDot:1
+12 IF $ORDER(FN(0))
SET N=0
FOR
SET N=$ORDER(FN(N))
if 'N
QUIT
Begin DoDot:1
+13 if FN(N)=""
QUIT
SET FNX=FN(N)
+14 if ($GET(DR(FNX))="")!($GET(DA(FNX))="")!($GET(ZX(FNX))="")
QUIT
+15 SET ZX=ZX(FNX)
SET FNX=FN(N)
SET DAX=DA(FNX)
SET DRX=DR(FNX)
+16 FOR I=1:1
if $PIECE(ZX,";",I)=""
QUIT
Begin DoDot:2
+17 SET ZY=$PIECE(ZX,";",I)
+18 if ZY=""
QUIT
+19 XECUTE "S "_$PIECE(ZY,",")_"=$G("_DIQ_"FNX,DAX,$P(DRX,"";"",I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
+20 IF $PIECE(ZY,",",3)]""
SET ZY=$PIECE(ZY,",",3,4)
XECUTE "S "_$PIECE(ZY,",")_"=$G("_DIQ_"FNX,DAX,$P(DRX,"";"",I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
+21 QUIT
End DoDot:2
End DoDot:1
+22 IF $EXTRACT(DIQ,$LENGTH(DIQ))=","
KILL @($EXTRACT(DIQ,$LENGTH(DIQ)-1)_")")
+23 IF $EXTRACT(DIQ,$LENGTH(DIQ))="("
KILL @($EXTRACT(DIQ,$LENGTH(DIQ)-1))
+24 QUIT
LZF(STRING,LENGTH) ;LEFT ZERO FILL STRING IN A FIELD LENGTH OF LENGTH
+1 NEW X
+2 SET $PIECE(X,"0",LENGTH)="0"
SET STRING=X_STRING
+3 QUIT $EXTRACT(STRING,$LENGTH(STRING)-(LENGTH-1),$LENGTH(STRING))
RZF(STRING,LENGTH) ;RIGHT ZERO FILL STRING IN A FIELD LENGTH OF LENGTH
+1 NEW X
+2 SET $PIECE(X,"0",LENGTH)=0
SET STRING=STRING_X
+3 QUIT $EXTRACT(STRING,1,LENGTH)
LBF(STRING,LENGTH) ;LEFT BLANK FILL STRING IN A FIELD LENGTH OF LENGTH
+1 NEW X
+2 SET $PIECE(X," ",LENGTH)=" "
SET STRING=X_STRING
+3 QUIT $EXTRACT(STRING,$LENGTH(STRING)-(LENGTH-1),$LENGTH(STRING))
RBF(STRING,LENGTH) ;RIGHT BLANK FILL STRING IN A FIELD LENGTH OF LENGTH
+1 NEW X
+2 SET $PIECE(X," ",LENGTH)=" "
SET STRING=STRING_X
+3 QUIT $EXTRACT(STRING,1,LENGTH)
DIR() ;SET VARIABLE STRING RETURNING FROM DIR
+1 NEW X
+2 SET X=$DATA(DTOUT)_$DATA(DUOUT)_$DATA(DIRUT)_$DATA(DIROUT)
+3 KILL DTOUT,DUOUT,DIRUT,DIROUT
+4 QUIT X
+5 ;
FULLDAT(Y) ;CONVERTS FILEMAN INTERNAL DATE TO EXTERNAL FORMAT
+1 if Y
SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),"^",Y[".")
+2 QUIT Y
+3 ;
EXTSSN(X) ;RETURNS EXTERNAL VALUE OF SSN
+1 IF X'?9N
QUIT X
+2 QUIT $EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,9)
+3 ;
LOWER(X) ;RETURNS STRING X IN LOWER CASE
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UPPER(X) ;RETURNS STRING X IN UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
AGE(X2,X1) ;extrinsic function returns current age based on date X
+1 NEW %,%H,%I,%T,X,%Y
+2 IF $GET(X1)=""
DO NOW^%DTC
SET X1=X
+3 DO ^%DTC
+4 QUIT X\365.25
SETOFCDS ;display set of codes
+1 NEW X,LN,Y
+2 if $PIECE($GET(DIR(0)),"^",1)'["S"
QUIT
+3 WRITE !,"Select From:",!
+4 SET X=$PIECE(DIR(0),"^",2)
+5 FOR LN=1:1
if $PIECE(X,";",LN)=""
QUIT
SET Y=$PIECE(X,";",LN)
WRITE !?5,$PIECE(Y,":"),?15,$PIECE(Y,":",2)
+6 QUIT
+7 ;
VPHONE(X) ;extrinsic function, for validating telephone numbers
+1 NEW PRPFX
+2 IF X=""
QUIT 0
+3 IF X?7N
QUIT 1
+4 IF X?3N1"-"4N
QUIT 1
+5 IF X?10N
QUIT 1
+6 IF X?3N1"-"3N1"-"4N
QUIT 1
+7 IF X?7N1" ".6UN
QUIT 1
+8 IF X?3N1"-"4N1" ".6UN
QUIT 1
+9 IF X?10N1" ".6UN
QUIT 1
+10 IF X?3N1"-"3N1"-"4N1" ".6UN
QUIT 1
+11 QUIT 0
PHONEOUT(X) ;extrinsic function to print phone number
+1 IF $EXTRACT(X,1,10)?10N
QUIT $EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,99)
+2 IF $EXTRACT(X,1,7)?7N
QUIT " "_$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,99)
+3 IF X?10N1" ".6UN
QUIT $EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,99)
+4 IF X?3N1"-"4N
QUIT " "_X
+5 IF X?3N1"-"4N.1" ".6UN
QUIT " "_X
+6 QUIT X
