NUPABCL ;PHOENIX/KLD; 7/1/99; ADMISSION ASSESSMENT BROKER CALL UTILITIES; 1/11/12 8:37 AM
;;1.0;NUPA;;;Build 105
ST Q
;
LOOK(RESULT,PAR) ;Lookup data using ^DIC
;F=file number, V=Value to lookup, FD=fields to display,
;IND=indexes to search, NUM=# of entries to display, SCR=screen
S:PAR("V")="DUZ" PAR("V")="`"_DUZ S:$G(PAR("IND"))="" PAR("IND")="B"
S:PAR("F")=2&(PAR("IND")'["BS5") PAR("IND")=PAR("IND")_"^BS5"
S:'+$G(PAR("NUM")) PAR("NUM")=20
N I F I="F","V","FD","IND","NUM","SCR" S PAR(I)=$G(PAR(I))
S:PAR("FD")="" PAR("FD")="@;.01"
S:PAR("FD")'="@;.01"&$E(PAR("FD")'="@") PAR("FD")="@;"_PAR("FD")
D:PAR("F")&(PAR("V")]"") FIND^DIC(PAR("F"),"",PAR("FD"),"P",PAR("V"),PAR("NUM"),PAR("IND"),PAR("SCR"),"","","")
I $D(^TMP("DILIST",$J)),'$D(^TMP("DILIST",$J,0)) S ^TMP("DILIST",$J,0)=$O(^TMP("DILIST",$J,9E9),-1)
S:'$D(^TMP("DILIST",$J)) ^TMP("DILIST",$J,0)="0^*^0"
I $D(^TMP("DIERR",$J)),'$D(^TMP("DILIST",$J,1,0)) K ^TMP("DILIST",$J) D
.S ^TMP("DILIST",$J,0)="666^*^1^ERROR",^TMP("DILIST",$J,1,0)=$G(^TMP("DIERR",$J,1,"TEXT",1))
K ^TMP("DILIST",$J,0,"MAP") S RESULT=$NA(^TMP("DILIST",$J)) Q
;
DLOOK(RESULT,F,V,TYPE,SCR,IND) ;Lookup using the IND xref for when the .01 is a date or pointer.
;F=file number, V=Value to lookup
N C34,CNT,FLAG,G1,G2,GLO1,GLO2,I,II S C34=$C(34),SCR=$G(SCR),CNT=0
S:$G(TYPE)="" TYPE="D" S:$G(IND)="" IND="B" K ^TMP($J)
S GLO1=^DIC(F,0,"GL")_""""_IND_"""," S:TYPE'="VP" GLO1=GLO1_(V-.001)
S:TYPE="VP" GLO1=GLO1_C34_($P(V,";")-1)_";"_$P(V,";",2)_C34
S GLO1=GLO1_")"
F I=0:0 S G1=$O(@GLO1) Q:G1=""!(G1'[V) D
.S:TYPE'="VP" GLO1=$P(GLO1,",",1,2)_","_G1_")"
.S:TYPE="VP" GLO1=$P(GLO1,",",1,2)_","_C34_G1_C34_")"
.S GLO2=$P(GLO1,")")_",0)"
.F II=0:0 S G2=$O(@GLO2) Q:G2="" S FLAG=1 D
..I SCR]"" S X=@($P(GLO2,",")_","_G2_",0)") X SCR S FLAG=$T
..I FLAG S CNT=CNT+1 S:TYPE="D" ^TMP($J,CNT)=$$D(G1) D
...S:TYPE="P"!(TYPE="VP") ^TMP($J,CNT)=G1
...S ^TMP($J,CNT)=^TMP($J,CNT)_U_G2_U_@(^DIC(F,0,"GL")_G2_",0)")
..S:TYPE'="VP" GLO2=$P(GLO1,",",1,2)_","_G1_","_G2_")"
..S:TYPE="VP" GLO2=$P(GLO1,",",1,2)_","_C34_G1_C34_","_G2_")"
S:'$D(^TMP($J)) ^TMP($J,1)=0 S RESULT=$NA(^TMP($J)) Q
;
WPSET(RESULT,F,N,D) ;Stick data into a word processing field one line at a time
;F=file (global name), N=Line number, D=Data to insert
I $G(F)=""!('$G(N))!($G(D)="") S RESULT=0 Q
S D=$G(D),F=F_")" I N<2 K @F Q:'N
S F=$P(F,")")_",0)",@F="^^"_N_U_N_U_DT_U
S F=$P(F,"0)")_N_",0)",@F=D,RESULT=1 Q
;
WPGET(RESULT,F,IEN,N) ;Get data from a word processing field
;F=file (global name- "^DIZ(644123,"), IEN=Line number+",", N=Node
K ^TMP($J) S ^TMP($J)=""
I F]"",","'[IEN,N]"" M ^TMP($J)=@(F_IEN_N_")") K ^TMP($J,0) S:'$D(^TMP($J)) ^TMP($J,1,0)=""
S RESULT=$NA(^TMP($J)) Q
;
FILE(RESULT,DIE,DA,F,V,S) ;File info - F=Field, V=Value, S=# of slashes
;DA can have pieces for DA(1), DA(2), etc.
N DR,I F I=2:1 Q:$P(DA,U,I)="" S DA(I-1)=$P(DA,U,I)
S DA=+DA S:'$D(S) S=V,V="" F I=1:1:S S F=F_"/"
S DR=F_V D ^DIE S RESULT=1 Q
;
NEW(RESULT,DIC,X,XX) ;Add a new entry to a file
N % S DIC=$G(DIC),X=$G(X),XX=$G(XX) I DIC=""!(X="") S RESULT=0 Q
I X="NOW" D NOW^%DTC S X=%
D ADD Q
;
NEWN(RESULT,DIC,X,S) ;Add new entry if none already exists
N DOLRT,Y S X=$G(X) I X="" S RESULT=-1 Q
S S=$G(S),Y=0
NEWN1 S:X'?1.N X=$C(34)_X_$C(34) S Y=$O(@(DIC_"""B"""_","_X_","_Y_")"))
S:$E(X)=$C(34)&($E(X,$L(X))=$C(34)) X=$E(X,2,$L(X)-1)
I 'Y D ADD Q ;none exists
S DOLRT=1 I S]"" X S S DOLRT=$T
I DOLRT S RESULT=Y Q ;entry has desired value
G NEWN1
;
ADD S:'$D(DA(1))&($L(DIC,",")=4) DA(1)=$P(DIC,",",2)
S:$L(DIC,",")=6 DA(2)=$P(DIC,",",2),DA(1)=$P(DIC,",",4)
S:$L(DIC,",")=8 DA(3)=$P(DIC,",",2),DA(2)=$P(DIC,",",5),DA(1)=$P(DIC,",",6)
K DD,DO S DIC(0)="L" D FILE^DICN S RESULT=+Y Q
;
SCREEN(R,S) ;Xecute a screen (or xecutable code)
N NUPA,X S X="SCRERR^NUPABCL",@^%ZOSF("TRAP")
S X=S D ^DIM I '$D(X) S R=""
E X S S R=$T
SCRERR S:'$D(R) R="" S:$D(NUPA) R=NUPA Q
; ;
DATE(RESULT,X) ;Return a date from a string
N %DT S %DT="T" D ^%DT S RESULT=Y Q
;
LIST(RESULT,F,S,M) ;List of all entries from a file.
;F=file number, S=Screen, M=Subscript of a multiple
;May not work well if .01 is a pointer
N CNT,I,II,X K ^TMP($J) I '$D(^DIC(F,0,"GL")) S ^TMP($J,0)="" Q
S F=^DIC(F,0,"GL"),S=$G(S),M=$G(M)
D LISTGET S RESULT=$NA(^TMP($J)) Q
;
LIST2(RESULT,F,FD,S) ;List of all entries from a file including other fields
;F=file in format "^DIZ(644123,", S=Screen
;FD=other fields in format FILE^Field 1^Field 2 etc
N I,II,OFD S FD=$G(FD),S=$G(S),M="" K ^TMP($J)
I FD]"" F I=2:1 Q:$P(FD,U,I)="" D
.S OFD=$G(OFD)+1,OFD(OFD)=$P(^DD(+FD,$P(FD,U,I),0),U,4)
D LISTGET S RESULT=$NA(^TMP($J)) Q
;
LISTGET N OFDV F I=0:0 S I=$O(@(F_"I)")) Q:'I S X=$G(^(I,0)) D:X]""
.I S]"" X S Q:'$T
.I M D Q
..F II=0:0 S II=$O(@(F_"I,M,II)")) Q:'II S ^TMP($J,"B",$P(^(II,0),U),II)=""
.I $G(OFD) F II=1:1:OFD S OFDV(II)=$P($G(^(+OFD(II))),U,$P(OFD(II),";",2))
.Q:$P(X,U)="" S ^TMP($J,"B",$P(X,U),I)=""
.I $D(OFDV) F II=1:1 Q:'$D(OFDV(II)) S ^TMP($J,"B",$P(X,U),I)=^TMP($J,"B",$P(X,U),I)_U_OFDV(II)
S CNT=0,I="" F S I=$O(^TMP($J,"B",I)) Q:I="" D
.F II=0:0 S II=$O(^TMP($J,"B",I,II)) Q:'II D
..S CNT=CNT+1,^TMP($J,CNT)=I_U_II_^TMP($J,"B",I,II)
K ^TMP($J,"B") S:'$D(^TMP($J)) ^TMP($J,1)="NOTHING FOUND" Q
;
PF(R,X,FP) ;Is Date X > OR < $H? X should be in "7/7/11@12:30:00 PM" format.
;Set FP to "P" to check if X is in the past, or set FP to "F"
;to see if X is in the future. R will equal 0 or 1.
N %,CHKDT D RDFD(.CHKDT,X),NOW^%DTC S FP=$G(FP),R=-1
S:FP="P" R=$S(CHKDT<%:1,1:0) S:FP="F" R=$S(CHKDT>%:1,1:0)
Q
;
CDTR(RESULT) ;Current date/time (regular format)
N % D NOW^%DTC S RESULT=$$D1($P(%,"."))_" "_$$T1($P(%,".",2)) Q
CDTF(RESULT) ;Current date/time (fileman format)
N % D NOW^%DTC S RESULT=% Q
;
FDRD(R,Y) ;Convert Fileman date to regular date
D DD^%DT S R=Y Q
RDFD(R,X) ;Convert regular date to Fileman date
N %DT S %DT="TS" D ^%DT S R=Y Q
;
D(Y) D DD^%DT Q Y
D1(Y) Q +$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_$E(Y,2,3)
T1(Y) N H S Y=Y_"000000",H=$E(Y,1,2)
S Y=":"_$E(Y,3,4)_$S($E(Y,1,2)<12:" AM",1:" PM")
Q $S(+H=0:12,+H<13:+H,1:(H-12))_Y
;
P(R,ZTIO,PR) ;Print an array to printer
N ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
S ZTRTN="P1^NUPABCL",ZTDESC="PRINT RPC",ZTSAVE("PR(")="",ZTDTH=$H
D ^%ZTLOAD S R=+$G(ZTSK) Q
;
P1 U IO F I=0:0 S I=$O(PR(I)) Q:I="" D
.I $E(PR(I))=$C(12) W:I>1 @IOF S PR(I)=$E(PR(I),2,999)
.W !,PR(I)
D ^%ZISC Q
;
VD(R,X) ;Is data valid for a Fileman file's field? X=File #^Field #^Data
N F,G S G=+X,F=$P(X,U,2),X=$P(X,U,3) X $P(^DD(G,F,0),U,5,99)
S R=$D(X) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNUPABCL 6703 printed Oct 16, 2024@18:24:52 Page 2
NUPABCL ;PHOENIX/KLD; 7/1/99; ADMISSION ASSESSMENT BROKER CALL UTILITIES; 1/11/12 8:37 AM
+1 ;;1.0;NUPA;;;Build 105
ST QUIT
+1 ;
LOOK(RESULT,PAR) ;Lookup data using ^DIC
+1 ;F=file number, V=Value to lookup, FD=fields to display,
+2 ;IND=indexes to search, NUM=# of entries to display, SCR=screen
+3 if PAR("V")="DUZ"
SET PAR("V")="`"_DUZ
if $GET(PAR("IND"))=""
SET PAR("IND")="B"
+4 if PAR("F")=2&(PAR("IND")'["BS5")
SET PAR("IND")=PAR("IND")_"^BS5"
+5 if '+$GET(PAR("NUM"))
SET PAR("NUM")=20
+6 NEW I
FOR I="F","V","FD","IND","NUM","SCR"
SET PAR(I)=$GET(PAR(I))
+7 if PAR("FD")=""
SET PAR("FD")="@;.01"
+8 if PAR("FD")'="@;.01"&$EXTRACT(PAR("FD")'="@")
SET PAR("FD")="@;"_PAR("FD")
+9 if PAR("F")&(PAR("V")]"")
DO FIND^DIC(PAR("F"),"",PAR("FD"),"P",PAR("V"),PAR("NUM"),PAR("IND"),PAR("SCR"),"","","")
+10 IF $DATA(^TMP("DILIST",$JOB))
IF '$DATA(^TMP("DILIST",$JOB,0))
SET ^TMP("DILIST",$JOB,0)=$ORDER(^TMP("DILIST",$JOB,9E9),-1)
+11 if '$DATA(^TMP("DILIST",$JOB))
SET ^TMP("DILIST",$JOB,0)="0^*^0"
+12 IF $DATA(^TMP("DIERR",$JOB))
IF '$DATA(^TMP("DILIST",$JOB,1,0))
KILL ^TMP("DILIST",$JOB)
Begin DoDot:1
+13 SET ^TMP("DILIST",$JOB,0)="666^*^1^ERROR"
SET ^TMP("DILIST",$JOB,1,0)=$GET(^TMP("DIERR",$JOB,1,"TEXT",1))
End DoDot:1
+14 KILL ^TMP("DILIST",$JOB,0,"MAP")
SET RESULT=$NAME(^TMP("DILIST",$JOB))
QUIT
+15 ;
DLOOK(RESULT,F,V,TYPE,SCR,IND) ;Lookup using the IND xref for when the .01 is a date or pointer.
+1 ;F=file number, V=Value to lookup
+2 NEW C34,CNT,FLAG,G1,G2,GLO1,GLO2,I,II
SET C34=$CHAR(34)
SET SCR=$GET(SCR)
SET CNT=0
+3 if $GET(TYPE)=""
SET TYPE="D"
if $GET(IND)=""
SET IND="B"
KILL ^TMP($JOB)
+4 SET GLO1=^DIC(F,0,"GL")_""""_IND_""","
if TYPE'="VP"
SET GLO1=GLO1_(V-.001)
+5 if TYPE="VP"
SET GLO1=GLO1_C34_($PIECE(V,";")-1)_";"_$PIECE(V,";",2)_C34
+6 SET GLO1=GLO1_")"
+7 FOR I=0:0
SET G1=$ORDER(@GLO1)
if G1=""!(G1'[V)
QUIT
Begin DoDot:1
+8 if TYPE'="VP"
SET GLO1=$PIECE(GLO1,",",1,2)_","_G1_")"
+9 if TYPE="VP"
SET GLO1=$PIECE(GLO1,",",1,2)_","_C34_G1_C34_")"
+10 SET GLO2=$PIECE(GLO1,")")_",0)"
+11 FOR II=0:0
SET G2=$ORDER(@GLO2)
if G2=""
QUIT
SET FLAG=1
Begin DoDot:2
+12 IF SCR]""
SET X=@($PIECE(GLO2,",")_","_G2_",0)")
XECUTE SCR
SET FLAG=$TEST
+13 IF FLAG
SET CNT=CNT+1
if TYPE="D"
SET ^TMP($JOB,CNT)=$$D(G1)
Begin DoDot:3
+14 if TYPE="P"!(TYPE="VP")
SET ^TMP($JOB,CNT)=G1
+15 SET ^TMP($JOB,CNT)=^TMP($JOB,CNT)_U_G2_U_@(^DIC(F,0,"GL")_G2_",0)")
End DoDot:3
+16 if TYPE'="VP"
SET GLO2=$PIECE(GLO1,",",1,2)_","_G1_","_G2_")"
+17 if TYPE="VP"
SET GLO2=$PIECE(GLO1,",",1,2)_","_C34_G1_C34_","_G2_")"
End DoDot:2
End DoDot:1
+18 if '$DATA(^TMP($JOB))
SET ^TMP($JOB,1)=0
SET RESULT=$NAME(^TMP($JOB))
QUIT
+19 ;
WPSET(RESULT,F,N,D) ;Stick data into a word processing field one line at a time
+1 ;F=file (global name), N=Line number, D=Data to insert
+2 IF $GET(F)=""!('$GET(N))!($GET(D)="")
SET RESULT=0
QUIT
+3 SET D=$GET(D)
SET F=F_")"
IF N<2
KILL @F
if 'N
QUIT
+4 SET F=$PIECE(F,")")_",0)"
SET @F="^^"_N_U_N_U_DT_U
+5 SET F=$PIECE(F,"0)")_N_",0)"
SET @F=D
SET RESULT=1
QUIT
+6 ;
WPGET(RESULT,F,IEN,N) ;Get data from a word processing field
+1 ;F=file (global name- "^DIZ(644123,"), IEN=Line number+",", N=Node
+2 KILL ^TMP($JOB)
SET ^TMP($JOB)=""
+3 IF F]""
IF ","'[IEN
IF N]""
MERGE ^TMP($JOB)=@(F_IEN_N_")")
KILL ^TMP($JOB,0)
if '$DATA(^TMP($JOB))
SET ^TMP($JOB,1,0)=""
+4 SET RESULT=$NAME(^TMP($JOB))
QUIT
+5 ;
FILE(RESULT,DIE,DA,F,V,S) ;File info - F=Field, V=Value, S=# of slashes
+1 ;DA can have pieces for DA(1), DA(2), etc.
+2 NEW DR,I
FOR I=2:1
if $PIECE(DA,U,I)=""
QUIT
SET DA(I-1)=$PIECE(DA,U,I)
+3 SET DA=+DA
if '$DATA(S)
SET S=V
SET V=""
FOR I=1:1:S
SET F=F_"/"
+4 SET DR=F_V
DO ^DIE
SET RESULT=1
QUIT
+5 ;
NEW(RESULT,DIC,X,XX) ;Add a new entry to a file
+1 NEW %
SET DIC=$GET(DIC)
SET X=$GET(X)
SET XX=$GET(XX)
IF DIC=""!(X="")
SET RESULT=0
QUIT
+2 IF X="NOW"
DO NOW^%DTC
SET X=%
+3 DO ADD
QUIT
+4 ;
NEWN(RESULT,DIC,X,S) ;Add new entry if none already exists
+1 NEW DOLRT,Y
SET X=$GET(X)
IF X=""
SET RESULT=-1
QUIT
+2 SET S=$GET(S)
SET Y=0
NEWN1 if X'?1.N
SET X=$CHAR(34)_X_$CHAR(34)
SET Y=$ORDER(@(DIC_"""B"""_","_X_","_Y_")"))
+1 if $EXTRACT(X)=$CHAR(34)&($EXTRACT(X,$LENGTH(X))=$CHAR(34))
SET X=$EXTRACT(X,2,$LENGTH(X)-1)
+2 ;none exists
IF 'Y
DO ADD
QUIT
+3 SET DOLRT=1
IF S]""
XECUTE S
SET DOLRT=$TEST
+4 ;entry has desired value
IF DOLRT
SET RESULT=Y
QUIT
+5 GOTO NEWN1
+6 ;
ADD if '$DATA(DA(1))&($LENGTH(DIC,",")=4)
SET DA(1)=$PIECE(DIC,",",2)
+1 if $LENGTH(DIC,",")=6
SET DA(2)=$PIECE(DIC,",",2)
SET DA(1)=$PIECE(DIC,",",4)
+2 if $LENGTH(DIC,",")=8
SET DA(3)=$PIECE(DIC,",",2)
SET DA(2)=$PIECE(DIC,",",5)
SET DA(1)=$PIECE(DIC,",",6)
+3 KILL DD,DO
SET DIC(0)="L"
DO FILE^DICN
SET RESULT=+Y
QUIT
+4 ;
SCREEN(R,S) ;Xecute a screen (or xecutable code)
+1 NEW NUPA,X
SET X="SCRERR^NUPABCL"
SET @^%ZOSF("TRAP")
+2 SET X=S
DO ^DIM
IF '$DATA(X)
SET R=""
+3 IF '$TEST
XECUTE S
SET R=$TEST
SCRERR if '$DATA(R)
SET R=""
if $DATA(NUPA)
SET R=NUPA
QUIT
+1 ; ;
DATE(RESULT,X) ;Return a date from a string
+1 NEW %DT
SET %DT="T"
DO ^%DT
SET RESULT=Y
QUIT
+2 ;
LIST(RESULT,F,S,M) ;List of all entries from a file.
+1 ;F=file number, S=Screen, M=Subscript of a multiple
+2 ;May not work well if .01 is a pointer
+3 NEW CNT,I,II,X
KILL ^TMP($JOB)
IF '$DATA(^DIC(F,0,"GL"))
SET ^TMP($JOB,0)=""
QUIT
+4 SET F=^DIC(F,0,"GL")
SET S=$GET(S)
SET M=$GET(M)
+5 DO LISTGET
SET RESULT=$NAME(^TMP($JOB))
QUIT
+6 ;
LIST2(RESULT,F,FD,S) ;List of all entries from a file including other fields
+1 ;F=file in format "^DIZ(644123,", S=Screen
+2 ;FD=other fields in format FILE^Field 1^Field 2 etc
+3 NEW I,II,OFD
SET FD=$GET(FD)
SET S=$GET(S)
SET M=""
KILL ^TMP($JOB)
+4 IF FD]""
FOR I=2:1
if $PIECE(FD,U,I)=""
QUIT
Begin DoDot:1
+5 SET OFD=$GET(OFD)+1
SET OFD(OFD)=$PIECE(^DD(+FD,$PIECE(FD,U,I),0),U,4)
End DoDot:1
+6 DO LISTGET
SET RESULT=$NAME(^TMP($JOB))
QUIT
+7 ;
LISTGET NEW OFDV
FOR I=0:0
SET I=$ORDER(@(F_"I)"))
if 'I
QUIT
SET X=$GET(^(I,0))
if X]""
Begin DoDot:1
+1 IF S]""
XECUTE S
if '$TEST
QUIT
+2 IF M
Begin DoDot:2
+3 FOR II=0:0
SET II=$ORDER(@(F_"I,M,II)"))
if 'II
QUIT
SET ^TMP($JOB,"B",$PIECE(^(II,0),U),II)=""
End DoDot:2
QUIT
+4 IF $GET(OFD)
FOR II=1:1:OFD
SET OFDV(II)=$PIECE($GET(^(+OFD(II))),U,$PIECE(OFD(II),";",2))
+5 if $PIECE(X,U)=""
QUIT
SET ^TMP($JOB,"B",$PIECE(X,U),I)=""
+6 IF $DATA(OFDV)
FOR II=1:1
if '$DATA(OFDV(II))
QUIT
SET ^TMP($JOB,"B",$PIECE(X,U),I)=^TMP($JOB,"B",$PIECE(X,U),I)_U_OFDV(II)
End DoDot:1
+7 SET CNT=0
SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"B",I))
if I=""
QUIT
Begin DoDot:1
+8 FOR II=0:0
SET II=$ORDER(^TMP($JOB,"B",I,II))
if 'II
QUIT
Begin DoDot:2
+9 SET CNT=CNT+1
SET ^TMP($JOB,CNT)=I_U_II_^TMP($JOB,"B",I,II)
End DoDot:2
End DoDot:1
+10 KILL ^TMP($JOB,"B")
if '$DATA(^TMP($JOB))
SET ^TMP($JOB,1)="NOTHING FOUND"
QUIT
+11 ;
PF(R,X,FP) ;Is Date X > OR < $H? X should be in "7/7/11@12:30:00 PM" format.
+1 ;Set FP to "P" to check if X is in the past, or set FP to "F"
+2 ;to see if X is in the future. R will equal 0 or 1.
+3 NEW %,CHKDT
DO RDFD(.CHKDT,X)
DO NOW^%DTC
SET FP=$GET(FP)
SET R=-1
+4 if FP="P"
SET R=$SELECT(CHKDT<%:1,1:0)
if FP="F"
SET R=$SELECT(CHKDT>%:1,1:0)
+5 QUIT
+6 ;
CDTR(RESULT) ;Current date/time (regular format)
+1 NEW %
DO NOW^%DTC
SET RESULT=$$D1($PIECE(%,"."))_" "_$$T1($PIECE(%,".",2))
QUIT
CDTF(RESULT) ;Current date/time (fileman format)
+1 NEW %
DO NOW^%DTC
SET RESULT=%
QUIT
+2 ;
FDRD(R,Y) ;Convert Fileman date to regular date
+1 DO DD^%DT
SET R=Y
QUIT
RDFD(R,X) ;Convert regular date to Fileman date
+1 NEW %DT
SET %DT="TS"
DO ^%DT
SET R=Y
QUIT
+2 ;
D(Y) DO DD^%DT
QUIT Y
D1(Y) QUIT +$EXTRACT(Y,4,5)_"/"_+$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
T1(Y) NEW H
SET Y=Y_"000000"
SET H=$EXTRACT(Y,1,2)
+1 SET Y=":"_$EXTRACT(Y,3,4)_$SELECT($EXTRACT(Y,1,2)<12:" AM",1:" PM")
+2 QUIT $SELECT(+H=0:12,+H<13:+H,1:(H-12))_Y
+3 ;
P(R,ZTIO,PR) ;Print an array to printer
+1 NEW ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
+2 SET ZTRTN="P1^NUPABCL"
SET ZTDESC="PRINT RPC"
SET ZTSAVE("PR(")=""
SET ZTDTH=$HOROLOG
+3 DO ^%ZTLOAD
SET R=+$GET(ZTSK)
QUIT
+4 ;
P1 USE IO
FOR I=0:0
SET I=$ORDER(PR(I))
if I=""
QUIT
Begin DoDot:1
+1 IF $EXTRACT(PR(I))=$CHAR(12)
if I>1
WRITE @IOF
SET PR(I)=$EXTRACT(PR(I),2,999)
+2 WRITE !,PR(I)
End DoDot:1
+3 DO ^%ZISC
QUIT
+4 ;
VD(R,X) ;Is data valid for a Fileman file's field? X=File #^Field #^Data
+1 NEW F,G
SET G=+X
SET F=$PIECE(X,U,2)
SET X=$PIECE(X,U,3)
XECUTE $PIECE(^DD(G,F,0),U,5,99)
+2 SET R=$DATA(X)
QUIT
