- 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 Feb 18, 2025@23:50 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