- PRPFU1 ;ALTOONA/CTB PATIENT FUNDS UTILITY PROGRAM ;11/22/96 4:47 PM
- V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
- ;ENTRY TO BREAK OUT FULL DESSCIPTION FROM SET OF CODES
- ;VARIABLES: X=INTERNAL VALUE
- ; DD=DD NUMBER
- ; F=FIELD NUMBER
- ;RETURNS DESCRIPTION VALUE IN VARIABLE Y
- ;RETURNS %=1 WHEN SUCCESSFUL, %=0 WHEN LOOKUP FAILED
- ;X,DD,F ARE KILLED
- SE I X="" S Y="" Q
- S I=2 D SET,Y^DIQ,KILL Q
- SET K Y S U="^",%=0,Y="" Q:'$D(X)!('$D(DD))!('$D(F))
- Q:X=""!(DD="")!(F="")
- S Y=X,X="S C=$P(^DD("_DD_","_F_",0),U,"_I_")" X X Q
- Q
- KILL K DD,I,C,X,F Q
- EXIT ;MASTER MENU EXIT LINE
- K PRPF Q
- DATE(Y) ;FUNCTION TO RETURN DATE IN EXTERNAL FORMAT
- D D Q Y
- ;
- D ;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
- MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
- N X1,X2,ZX Q:'$D(X) I $S('$D(IOM):1,IOM="":1,1:0) W $P(X,"*") R X:2 K X Q
- I ($L($P(X,"*"))+4+$X)>IOM W !,?(IOM-($L($P(X,"*"))+4))
- F ZX=1:1 D BRK:($L(X)+6)>IOM W " ",$P(X,"*"),! Q:'$D(X1) S X=X1 K X1
- W:X["*" *7
- Q
- BRK N I
- S X1=X F I=1:1 Q:$L($P(X," ",1,I))>(IOM-6)!($L(X)<(IOM-6)) S X1=$P(X," ",1,I)
- S X2=$P(X," ",I,999),X=X1,X1=X2 K X2 Q
- DGINPW S DFN(.1)="",DOA="" K VAINDT D INP^VADPT Q:$D(VAIN)<10
- I $D(VAIN(4)),VAIN(4)]"" S DFN(.1)=$P(VAIN(4),"^",2)
- I $D(VAIN(7)),VAIN(7)]"" S DOA=$P(VAIN(7),"^",2)
- K VAIN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFU1 1590 printed Jan 18, 2025@03:03:18 Page 2
- PRPFU1 ;ALTOONA/CTB PATIENT FUNDS UTILITY PROGRAM ;11/22/96 4:47 PM
- V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
- +1 ;ENTRY TO BREAK OUT FULL DESSCIPTION FROM SET OF CODES
- +2 ;VARIABLES: X=INTERNAL VALUE
- +3 ; DD=DD NUMBER
- +4 ; F=FIELD NUMBER
- +5 ;RETURNS DESCRIPTION VALUE IN VARIABLE Y
- +6 ;RETURNS %=1 WHEN SUCCESSFUL, %=0 WHEN LOOKUP FAILED
- +7 ;X,DD,F ARE KILLED
- SE IF X=""
- SET Y=""
- QUIT
- +1 SET I=2
- DO SET
- DO Y^DIQ
- DO KILL
- QUIT
- SET KILL Y
- SET U="^"
- SET %=0
- SET Y=""
- if '$DATA(X)!('$DATA(DD))!('$DATA(F))
- QUIT
- +1 if X=""!(DD="")!(F="")
- QUIT
- +2 SET Y=X
- SET X="S C=$P(^DD("_DD_","_F_",0),U,"_I_")"
- XECUTE X
- QUIT
- +3 QUIT
- KILL KILL DD,I,C,X,F
- QUIT
- EXIT ;MASTER MENU EXIT LINE
- +1 KILL PRPF
- QUIT
- DATE(Y) ;FUNCTION TO RETURN DATE IN EXTERNAL FORMAT
- +1 DO D
- QUIT Y
- +2 ;
- D ;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
- MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
- +1 NEW X1,X2,ZX
- if '$DATA(X)
- QUIT
- IF $SELECT('$DATA(IOM):1,IOM="":1,1:0)
- WRITE $PIECE(X,"*")
- READ X:2
- KILL X
- QUIT
- +2 IF ($LENGTH($PIECE(X,"*"))+4+$X)>IOM
- WRITE !,?(IOM-($LENGTH($PIECE(X,"*"))+4))
- +3 FOR ZX=1:1
- if ($LENGTH(X)+6)>IOM
- DO BRK
- WRITE " ",$PIECE(X,"*"),!
- if '$DATA(X1)
- QUIT
- SET X=X1
- KILL X1
- +4 if X["*"
- WRITE *7
- +5 QUIT
- BRK NEW I
- +1 SET X1=X
- FOR I=1:1
- if $LENGTH($PIECE(X," ",1,I))>(IOM-6)!($LENGTH(X)<(IOM-6))
- QUIT
- SET X1=$PIECE(X," ",1,I)
- +2 SET X2=$PIECE(X," ",I,999)
- SET X=X1
- SET X1=X2
- KILL X2
- QUIT
- DGINPW SET DFN(.1)=""
- SET DOA=""
- KILL VAINDT
- DO INP^VADPT
- if $DATA(VAIN)<10
- QUIT
- +1 IF $DATA(VAIN(4))
- IF VAIN(4)]""
- SET DFN(.1)=$PIECE(VAIN(4),"^",2)
- +2 IF $DATA(VAIN(7))
- IF VAIN(7)]""
- SET DOA=$PIECE(VAIN(7),"^",2)
- +3 KILL VAIN
- +4 QUIT