ORNORC ; SLC/AJB - New Order Checks for Cancelled Orders ;Mar 03, 2023@13:15:07
;;3.0;ORDER ENTRY/RESULTS REPORTING;**377,588**;Dec 17, 1997;Build 29
;
; Reference to ^DD( in ICR #999
;
Q
;
CANCEL(CHECKS,DFN,PACKAGE,LOC,DATA,STRT) ; capture a cancelled order
N ORDATA,ORDITM,ORIEN,ORIENS,ORITEMS,ORMSG
S (ORIEN(1),ORITEMS)=""
;Check for no previous Cancel entry and create a new entry if needed
S ORIEN(1)=$O(^XTMP("ORCHECK-"_DUZ,$J,DFN,$$DT^XLFDT,ORIEN(1)),-1)
I $G(ORIEN(1))="" D
. K ORIEN(1)
. S ORDATA(100.3,"+1,",.01)=$$NOW^XLFDT
. S ORDATA(100.3,"+1,",.02)=DFN
. S ORDATA(100.3,"+1,",.03)=DUZ
. S ORDATA(100.3,"+1,",.04)=+LOC
. S ORDATA(100.3,"+1,",.05)="C"
. S ORDATA(100.3,"+1,",.06)=PACKAGE
. S ORDATA(100.3,"+1,",.08)=STRT
. D UPDATE^DIE("","ORDATA","ORIEN","ORMSG") I +$D(ORMSG) Q
; get orderable item(s)
S ORDITM=0
F S ORDITM=$O(^OR(100.3,+ORIEN(1),1,ORDITM)) Q:+ORDITM=0 D
. S ORITEMS=$S(ORITEMS="":+$G(^OR(100.3,+ORIEN(1),1,ORDITM,0)),1:U_+$G(^OR(100.3,+ORIEN(1),1,ORDITM,0)))
N NUM S NUM=0 F S NUM=$O(DATA(NUM)) Q:'+NUM D
. I NUM=1 D
. . I ORITEMS[+DATA(NUM) Q
. . S ORDATA(100.31,"+1,"_ORIEN(1)_",",.01)=+DATA(NUM)
. . S ORITEMS=$S(ORITEMS="":+DATA(NUM),1:ORITEMS_U_+DATA(NUM))
. I $P(DATA(NUM),U,2)="ORDERABLE",ORITEMS'[$P(DATA(NUM),U,4) D
. . S ORDATA(100.31,"+1,"_ORIEN(1)_",",.01)=$P(DATA(NUM),U,4)
. . S ORITEMS=$S(ORITEMS="":$P(DATA(NUM),U,4),1:ORITEMS_U_$P(DATA(NUM),U,4))
. I +$D(ORDATA) D UPDATE^DIE("","ORDATA",,"ORMSG") I +$D(ORMSG) Q
; get order checks
S NUM=0 F S NUM=$O(CHECKS(NUM)) Q:'+NUM D
. N DATA,IEN,ORXTRA
. S ORDATA(100.32,"+1,"_ORIEN(1)_",",.01)=$P(CHECKS(NUM),U,2)
. S ORDATA(100.32,"+1,"_ORIEN(1)_",",.02)=$P(CHECKS(NUM),U,3)
. S ORDATA(100.32,"+1,"_ORIEN(1)_",",1)=$P(CHECKS(NUM),U,4)
. I ORDATA(100.32,"+1,"_ORIEN(1)_",",1)["||" D ; check for extra data
. . S ORXTRA=$P($P(ORDATA(100.32,"+1,"_ORIEN(1)_",",1),"||",2),"&")
. . S ORDATA(100.32,"+1,"_ORIEN(1)_",",1)=$P(ORDATA(100.32,"+1,"_ORIEN(1)_",",1),"&",2)
. . D GETXTRA^ORCHECK(.DATA,ORXTRA,ORDATA(100.32,"+1,"_ORIEN(1)_",",1))
. D UPDATE^DIE("","ORDATA","IEN","ORMSG") I +$D(ORMSG) Q
. D WP^DIE(100.32,IEN(1)_","_ORIEN(1)_",",2,,"DATA","ORMSG") I +$D(ORMSG) Q
; set raw order data
D WP^DIE(100.3,ORIEN(1)_",",3,,"DATA","ORMSG")
; set xtmp to find entries to be removed (#100.03) if order is initially accepted
I '+ORIEN(1) Q
S ^XTMP("ORCHECK-"_DUZ,0)=$$FMADD^XLFDT($$DT^XLFDT,1)_U_$$DT^XLFDT
S ^XTMP("ORCHECK-"_DUZ,$J,DFN,$$DT^XLFDT,ORIEN(1))=ORITEMS
Q
DELORC(ORVP,ORDIALOG) ; delete order checks from 100.3/avoid duplication in 100 & 100.05
N LOC S LOC=$NA(ORDIALOG),ORVP=+ORVP
I '+$D(^XTMP("ORCHECK-"_DUZ)) Q
N JOB,ORCHECK,ORITEMS,ORDT,NUM
S JOB=$J,ORDT=$$DT^XLFDT
S ORCHECK="",ORCHECK=$O(^XTMP("ORCHECK-"_DUZ,JOB,ORVP,ORDT,ORCHECK),-1) ; get most recent IEN from 100.3 for the given user,job,patient,date
I '+ORCHECK Q
S NUM=0,ORITEMS="" F S NUM=$O(@LOC@(4,NUM)) Q:'+NUM D
. S ORITEMS=$S(ORITEMS="":@LOC@(4,NUM),1:ORITEMS_U_@LOC@(4,NUM)) ; get all orderable items
I ORITEMS=^XTMP("ORCHECK-"_DUZ,JOB,ORVP,ORDT,ORCHECK) D
. N DA,DIK S DIK="^OR(100.3,",DA=ORCHECK D ^DIK ; remove entry from 100.3
. K ^XTMP("ORCHECK-"_DUZ,JOB,ORVP) ; remove xtmp data
Q
ORCAN(ORIEN,OCC) ; order has been cancelled/changed after acceptance
N ORCHK
D GETOC2^OROCAPI1(+ORIEN,.ORCHK) I '+$D(ORCHK) Q ; quit if no order checks for the order
N ORDATA,ORMSG
S ORDATA(100.3,"+1,",.01)=$$NOW^XLFDT
S ORDATA(100.3,"+1,",.02)=$G(DFN)
S ORDATA(100.3,"+1,",.03)=DUZ
S ORDATA(100.3,"+1,",.05)=OCC
S ORDATA(100.3,"+1,",.07)=+ORIEN
D UPDATE^DIE("","ORDATA","ORIEN","ORMSG") I +$D(ORMSG) Q
D ; get orderable items
. N DATA,IEN D GETS^DIQ(100,ORIEN,".1*","I","DATA")
. S IEN="" F S IEN=$O(DATA(100.001,IEN)) Q:'+IEN D
. . N ORDATA S ORDATA(100.31,"+1,"_ORIEN(1)_",",.01)=DATA(100.001,IEN,.01,"I")
. . D UPDATE^DIE("","ORDATA","","ORMSG")
S ORCHK=0 F S ORCHK=$O(ORCHK(ORIEN,ORCHK)) Q:'+ORCHK D
. N DATA,IEN,ORDATA D GETS^DIQ(100.05,ORCHK_",","5;6;8","I","DATA")
. S ORDATA(100.32,"+1,"_ORIEN(1)_",",.01)=DATA(100.05,ORCHK_",",5,"I")
. S ORDATA(100.32,"+1,"_ORIEN(1)_",",.02)=DATA(100.05,ORCHK_",",6,"I")
. S ORDATA(100.32,"+1,"_ORIEN(1)_",",1)=DATA(100.05,ORCHK_",",8,1)
. D UPDATE^DIE("","ORDATA","","ORMSG")
Q
EN ; main entry for creating a delimited report via HOST FILE or displaying CANCELLED ORDERS via ListManager
W @IOF
N CONT,LOC,POP,SRCH,X,Y
S CONT=0,LOC=$NA(^TMP("ORCHK",$J)) K @LOC ; set global location of entries
D SETUP(.SRCH) ; setup search parameters from user
I '+CONT W !!,"Search parameter entry aborted.",! Q
D FIND(.SRCH,LOC) ; find entries that match search criteria
I +$D(SRCH("DLM")) D Q
. N %ZIS,DSC,IOP,POP,RTN,ZTSAVE,ZTSK
. S ZTSAVE("JOB")="",ZTSAVE("SRCH")="",ZTSAVE("LOC")=""
. S %ZIS="Q" ;,%ZIS("HFSNAME")=SRCH("DLM"),IOP="Q;HFS"
. S DSC="Cancelled Order Report",RTN="REPORT^ORNORC(LOC)"
. W ! D EN^XUTMDEVQ(RTN,DSC,.ZTSAVE,.%ZIS,1)
. I +$G(ZTSK) W !!,"Task #",ZTSK
; start ListManager
D EN^OROCLM(.SRCH,LOC)
K @LOC
Q
SETUP(SRCH) ; user required input for search parameters
N DIR,POP,SRCHCRIT,X,Y
S DIR(0)="S^LM:ListManager;DLM:Delmited Data Host File"
S DIR("A")="LM/DLM",DIR("B")="LM"
S DIR("L",1)="Select which type of data output: "
S DIR("L",2)=""
S DIR("L",3)=" LM ListManager Display"
S DIR("L")=" DLM Delimited Data via Host File"
W ! D ^DIR I Y'["LM" Q
I Y="DLM" S SRCH("DLM")=1 ; D
;. S SRCH("DLM")=$$DEFDIR^%ZISH()_$$UP^XLFSTR($TR($$FMTE^XLFDT(DT,8)," ","_"))_"_ORDER_CHECK_REPORT.CSV"
;. W !!,"Your report will be located:",!!,$P(SRCH("DLM"),U),$P(SRCH("DLM"),U,2)
LM ;
D I '+$D(SRCH("ADATE"))!'+$D(SRCH("BDATE")) Q ; get a date range from user
. N %DT,DIR,X,Y S %DT(0)=-$$DT^XLFDT,%DT="AEX",%DT("A")="Select Beginning DATE: ",%DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30))
. W ! D ^%DT K %DT Q:Y<0 S SRCH("ADATE")=Y
. S DIR("A")=" Ending DATE: ",DIR("B")="TODAY",DIR(0)="DA"_U_SRCH("ADATE")_":"_$$DT^XLFDT_":EX"
. S DIR("?",1)="Enter a date between "_$$FMTE^XLFDT(SRCH("ADATE"))_" and "_$$FMTE^XLFDT($$DT^XLFDT)_".",DIR("?")=" "
. W ! D ^DIR Q:Y'>0 S SRCH("BDATE")=Y
;
S DIR(0)="YA",DIR("A")="Would you like to select additional SEARCH CRITERIA? ",DIR("B")="NO"
W ! D ^DIR I '+Y S CONT=$S(+$G(DIRUT):0,+$G(DUOUT):0,1:1) Q
;
S SRCHCRIT=$$SRCHCRIT(.SRCHCRIT,"A","OCCURRENCE","ORCHK SRCHPARAM 1 MAIN MENU","Enter search criteria: ") Q:SRCHCRIT=-1
S CONT=1 F X=1:1:SRCHCRIT D
. I SRCHCRIT(X)["LOCATION" D I SRCH("LOCATION")=-1 S X=SRCHCRIT,CONT=0 Q
. . W ! S SRCH("LOCATION")=$$FLU(44)
. I SRCHCRIT(X)["OCCURRENCE" D I '+$D(SRCH("OCCURRENCE")) S SRCH("OCCURRENCE")=-1,X=SRCHCRIT,CONT=0 Q
. . N SRCHCRIT,X S SRCHCRIT=$$SRCHCRIT(.SRCHCRIT,"A","CANCELLED","ORCHK SRCHPARAM 2 OCCURRENCE MENU","Enter OCCURRENCE(S): ") Q:SRCHCRIT=-1
. . S SRCH("OCCURRENCE")="" F X=1:1:SRCHCRIT D
. . . S SRCH("OCCURRENCE")=SRCH("OCCURRENCE")_$S($P(SRCHCRIT(X),U,3)="CANCELLED":"C",$P(SRCHCRIT(X),U,3)="ACCEPTED/CANCELLED":"AC",1:"RT")_$S(SRCHCRIT=X:"",1:U)
. I SRCHCRIT(X)["PATIENT" D I SRCH("PATIENT")=-1 S X=SRCHCRIT,CONT=0 Q
. . W ! S SRCH("PATIENT")=$$FLU(2)
. I SRCHCRIT(X)["USER" D I SRCH("USER")=-1 S X=SRCHCRIT,CONT=0 Q
. . W ! S SRCH("USER")=$$FLU(200)
. I SRCHCRIT(X)["ORDERABLE ITEM" D I SRCH("ORDITEM")=-1 S X=SRCHCRIT,CONT=0 Q
. . W ! S SRCH("ORDITEM")=$$FLU(101.43)
. I SRCHCRIT(X)["ORDER CHECK" D I SRCH("ORDCHECK")=-1 S X=SRCHCRIT,CONT=0 Q
. . W ! S SRCH("ORDCHECK")=$$FLU(100.8)
. I SRCHCRIT(X)["CLINICAL DANGER LEVEL" D I '+$D(SRCH("CDL")) S SRCH("CDL")=-1,X=SRCHCRIT,CONT=0 Q
. . N SRCHCRIT,X S SRCHCRIT=$$SRCHCRIT(.SRCHCRIT,"A","HIGH","ORCHK SRCHPARAM 3 DANGER MENU","Enter CLINICAL DANGER LEVEL: ") I SRCHCRIT=-1 S CONT=0 Q
. . S SRCH("CDL")="" F X=1:1:SRCHCRIT D
. . . S SRCH("CDL")=SRCH("CDL")_$S($P(SRCHCRIT(X),U,3)="HIGH":"1",$P(SRCHCRIT(X),U,3)="MEDIUM":"2",1:"3")_$S(SRCHCRIT=X:"",1:U)
Q
FIND(SRCH,LOC) ;
N BDT,GBL,IEN S IEN=0,GBL=$NA(^OR(100.3))
F BDT=SRCH("ADATE"):1:SRCH("BDATE") S IEN=0 F S IEN=$O(@GBL@("B",BDT,IEN)) Q:'+IEN D
. N DATA,MATCH S MATCH=""
. ; CANCELLED orders are only located in File #100.3
. I $G(SRCH("OCCURRENCE"))'="C",+$D(@GBL@("ORDER",IEN)) D
. . N OIEN S OIEN="",OIEN=$O(@GBL@("ORDER",IEN,OIEN)) Q:'+OIEN D
. . . N DATA1,ORCHK
. . . D GETS^DIQ(100,OIEN_",",".02;3;6;.1*","IN","DATA1")
. . . S DATA("PATIENT")=+DATA1(100,OIEN_",",.02,"I"),DATA("USER")=DATA1(100,OIEN_",",3,"I"),DATA("LOCATION")=+DATA1(100,OIEN_",",6,"I")
. . . S (DATA1,DATA("ORDITEM"))="" F S DATA1=$O(DATA1(100.001,DATA1)) Q:'+DATA1 D
. . . . S DATA("ORDITEM")=DATA("ORDITEM")_DATA1(100.001,DATA1,.01,"I")_$S(+$O(DATA1(100.001,DATA1)):U,1:"")
. . . D GETOC2^OROCAPI1(OIEN,.ORCHK)
. . . S (DATA("ORDCHECK"),DATA("CDL"),ORCHK)="" F S ORCHK=$O(ORCHK(OIEN,ORCHK)) Q:'+ORCHK D
. . . . D GETS^DIQ(100.05,ORCHK_",","5;6","IN","DATA1")
. . . . S DATA("ORDCHECK")=DATA("ORDCHECK")_DATA1(100.05,ORCHK_",",5,"I")_$S(+$O(ORCHK(OIEN,ORCHK)):U,1:"")
. . . . S DATA("CDL")=DATA("CDL")_DATA1(100.05,ORCHK_",",6,"I")_$S(+$O(ORCHK(OIEN,ORCHK)):U,1:"")
. S SRCH="BDATE" F S SRCH=$O(SRCH(SRCH)) Q:SRCH="" D
. . I SRCH="DLM" Q ; not a search parameter
. . S MATCH=MATCH_$$MATCH(SRCH,SRCH(SRCH),$G(DATA(SRCH)))_U
. I +$L(MATCH,U)=1 S MATCH=1 ; if no failed search parameters, it's a match
. I MATCH[0 Q
. S @LOC@(IEN)=""
Q
MATCH(INDEX,SRCHCRIT,DATA) ;
I SRCHCRIT=DATA Q 1
I +$D(@GBL@(INDEX,SRCH(INDEX),IEN)) Q 1
N X,Y S Y=0
I INDEX="CDL" F X=1:1:$L(SRCHCRIT,U) D
. I +$D(@GBL@(INDEX,$P(SRCHCRIT,U,X),IEN)) S Y=1 Q
. I DATA[$P(SRCHCRIT,U,X) S Y=1
I INDEX="OCCURRENCE" F X=1:1:$L(SRCHCRIT,U) I +$D(@GBL@(INDEX,$P(SRCHCRIT,U,X),IEN)) S Y=1 Q
I INDEX="ORDCHECK"!(INDEX="ORDITEM") F X=1:1:$L(DATA) D
. I $P(DATA,U,X)=SRCHCRIT S Y=1 Q
Q Y
FLU(FILE) ; file lookup
N DIC,FINFO,X,Y
D FILE^DID(FILE,,"NAME;GLOBAL NAME","FINFO")
S DIC=FINFO("GLOBAL NAME"),DIC(0)="AEMQ",DIC("A")="Select "_FINFO("NAME")_": "
D ^DIC
Q +Y
SRCHCRIT(Y,PARAM,DEFAULT,MENU,PROMPT) ; get search criteria using menu & actions from the protocol file
N I,X,XQORM
S XQORM=+$O(^ORD(101,"B",MENU,0))_";ORD(101,"
I '+XQORM Q "-1^Menu entry not found."
S XQORM(0)=$G(PARAM),XQORM("A")=PROMPT,XQORM("B")=DEFAULT
D EN^XQORM
Q $G(Y)
REPORT(LOC) ; writes the data for the host file(s)
N FCNT,FLDORD,IEN,IOM,SEQ S IOM=9999,SEQ=0 ; set sequence for fields
N DELIM S DELIM="," ; set delimiter for report
;
; Call FILEDD(<file#>) and S FCNT(SEQ,X)=FCNT for each FILE to be in the host file
; FCNT is the total field count for each file for displaying FILE info above headers
;
N X F X=100.3,100,100.05 S FCNT=0 D FILEDD(X) S FCNT(SEQ,X)=FCNT
;
D HDR K FLDORD
S IEN=0 F S IEN=$O(@LOC@(IEN)) Q:'+IEN D
. N ORDER,ORCHK
. D GODATA(100.3,IEN,1) ; main entry from File #100.3
. S ORDER=+$$GET1^DIQ(100.3,IEN,.07) I +ORDER D Q
. . D GODATA(100,ORDER) ; main entry from File #100 (ORDER) - one ORDER per CANCELLED ORDER (#100.3)
. . D GETOC2^OROCAPI1(ORDER,.ORCHK) ; get order checks for the ORDER
. . N CNT S CNT=0,ORCHK="" F S ORCHK=$O(ORCHK(ORDER,ORCHK)) Q:'+ORCHK D
. . . ; the main entry from File #100.05 (ORDER CHECK INSTANCES) - one or more per ORDER
. . . S CNT=CNT+1 I CNT=1 D GODATA(100.05,ORCHK) W $C(182) Q
. . . ; multi line results for an ORDER need "blank" entries for each file that precedes it
. . . D GODATA(100.3,,1),GODATA(100),GODATA(100.05,ORCHK) W $C(182)
. W $C(182)
K @LOC
Q
GODATA(FILE,IEN,STRT) ; get and output the file data
N DATA,FLDORD
N FN,FLD
I +$G(FILE),+$G(IEN) S IEN=IEN_"," D GETS^DIQ(FILE,IEN,"**","N","DATA")
W:+$G(STRT) ! W:'+$G(STRT) ","
D FILEDD(FILE)
S (SEQ,FN,FLD)=0 F S SEQ=$O(FLDORD(SEQ)) Q:'+SEQ F S FN=$O(FLDORD(SEQ,FN)) Q:'+FN F S FLD=$O(FLDORD(SEQ,FN,FLD)) Q:'+FLD D
. N CNT,SIEN S (CNT,SIEN)=""
. F S SIEN=$O(DATA(FN,SIEN)) Q:'+SIEN D
. . I +$D(DATA(FN,SIEN,FLD)) D
. . . S CNT=CNT+1
. . . W:CNT=1 $C(34)
. . . I $$GET1^DID(FN,FLD,,"TYPE")="WORD-PROCESSING" D
. . . . N NUM S NUM=0 F S NUM=$O(DATA(FN,SIEN,FLD,NUM)) Q:'+NUM D
. . . . . W $$QM(DATA(FN,SIEN,FLD,NUM)) W:+$O(DATA(FN,SIEN,FLD,NUM)) !
. . . W:$$GET1^DID(FN,FLD,,"TYPE")'="WORD-PROCESSING" $$QM(DATA(FN,SIEN,FLD))
. . . W:+$O(DATA(FN,SIEN)) !
. I +CNT D Q
. . W $C(34)
. . I +$O(FLDORD($S($$GET1^DID(FN,FLD,,"TYPE")="WORD-PROCESSING":(SEQ+1),1:SEQ))) W DELIM Q
. I '+CNT D
. . I +FLDORD(SEQ,FN,FLD),$$GET1^DID(FN,FLD,,"TYPE")="WORD-PROCESSING" D
. . . W $$QM("")
. . . I +$O(FLDORD((SEQ+1))) W DELIM Q
. . I '+FLDORD(SEQ,FN,FLD),$$GET1^DID(FN,FLD,,"TYPE")'="WORD-PROCESSING" D
. . . W $$QM("")
. . . I +$O(FLDORD(SEQ)) W DELIM Q
Q
FILEDD(FILENUM) ; establishes file/field sequence via the data dictionary ; IA #999
; FCNT,SEQ must be set prior to calling
N NODE,PIECE,FLD S (NODE,PIECE,FLD)=""
I +$D(^DD(FILENUM,"GL")) F S NODE=$O(^DD(FILENUM,"GL",NODE)) Q:NODE="" F S PIECE=$O(^DD(FILENUM,"GL",NODE,PIECE)) Q:PIECE="" F S FLD=$O(^DD(FILENUM,"GL",NODE,PIECE,FLD)) Q:'+FLD D
. N NODE0 S NODE0=$G(^DD(FILENUM,FLD,0))
. I +$P(NODE0,U,2) D Q
. . S SEQ=SEQ+1,FLDORD(SEQ,FILENUM,FLD)=+$P(NODE0,U,2)
. . D FILEDD(+$P(NODE0,U,2))
. S FCNT=FCNT+1,SEQ=SEQ+1,FLDORD(SEQ,FILENUM,FLD)=""
Q
HDR ; write field names for the column headers
N CNT,FILE,X
S CNT=1,(FCNT,FILE)="" F S FCNT=$O(FCNT(FCNT)) Q:'+FCNT F S FILE=$O(FCNT(FCNT,FILE)) Q:'+FILE D
. N NAME D FILE^DID(FILE,,"NAME","NAME")
. S CNT=CNT+FCNT(FCNT,FILE)
. S $P(X,DELIM,(CNT-FCNT(FCNT,FILE)))="File #"_FILE_" ["_NAME("NAME")_"]"
W X,!
;
N SEQ,FN,FLD
S (SEQ,FN,FLD)=0 F S SEQ=$O(FLDORD(SEQ)) Q:'+SEQ F S FN=$O(FLDORD(SEQ,FN)) Q:'+FN F S FLD=$O(FLDORD(SEQ,FN,FLD)) Q:'+FLD D
. I '+FLDORD(SEQ,FN,FLD) D Q ; not a multiple
. . W $$QM($$GET1^DID(FN,FLD,,"LABEL"),1) I +$O(FLDORD(SEQ)) W DELIM ; field data & delim
Q
QM(DATA,QM) ; for excel importing as csv, replace a single double quote with two double quotes
I DATA[$C(34) N X S X("""")="""""" S DATA=$$REPLACE^XLFSTR(DATA,.X)
Q $S(+$G(QM):$C(34)_DATA_$C(34),1:DATA)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORNORC 14224 printed Oct 16, 2024@18:32:51 Page 2
ORNORC ; SLC/AJB - New Order Checks for Cancelled Orders ;Mar 03, 2023@13:15:07
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**377,588**;Dec 17, 1997;Build 29
+2 ;
+3 ; Reference to ^DD( in ICR #999
+4 ;
+5 QUIT
+6 ;
CANCEL(CHECKS,DFN,PACKAGE,LOC,DATA,STRT) ; capture a cancelled order
+1 NEW ORDATA,ORDITM,ORIEN,ORIENS,ORITEMS,ORMSG
+2 SET (ORIEN(1),ORITEMS)=""
+3 ;Check for no previous Cancel entry and create a new entry if needed
+4 SET ORIEN(1)=$ORDER(^XTMP("ORCHECK-"_DUZ,$JOB,DFN,$$DT^XLFDT,ORIEN(1)),-1)
+5 IF $GET(ORIEN(1))=""
Begin DoDot:1
+6 KILL ORIEN(1)
+7 SET ORDATA(100.3,"+1,",.01)=$$NOW^XLFDT
+8 SET ORDATA(100.3,"+1,",.02)=DFN
+9 SET ORDATA(100.3,"+1,",.03)=DUZ
+10 SET ORDATA(100.3,"+1,",.04)=+LOC
+11 SET ORDATA(100.3,"+1,",.05)="C"
+12 SET ORDATA(100.3,"+1,",.06)=PACKAGE
+13 SET ORDATA(100.3,"+1,",.08)=STRT
+14 DO UPDATE^DIE("","ORDATA","ORIEN","ORMSG")
IF +$DATA(ORMSG)
QUIT
End DoDot:1
+15 ; get orderable item(s)
+16 SET ORDITM=0
+17 FOR
SET ORDITM=$ORDER(^OR(100.3,+ORIEN(1),1,ORDITM))
if +ORDITM=0
QUIT
Begin DoDot:1
+18 SET ORITEMS=$SELECT(ORITEMS="":+$GET(^OR(100.3,+ORIEN(1),1,ORDITM,0)),1:U_+$GET(^OR(100.3,+ORIEN(1),1,ORDITM,0)))
End DoDot:1
+19 NEW NUM
SET NUM=0
FOR
SET NUM=$ORDER(DATA(NUM))
if '+NUM
QUIT
Begin DoDot:1
+20 IF NUM=1
Begin DoDot:2
+21 IF ORITEMS[+DATA(NUM)
QUIT
+22 SET ORDATA(100.31,"+1,"_ORIEN(1)_",",.01)=+DATA(NUM)
+23 SET ORITEMS=$SELECT(ORITEMS="":+DATA(NUM),1:ORITEMS_U_+DATA(NUM))
End DoDot:2
+24 IF $PIECE(DATA(NUM),U,2)="ORDERABLE"
IF ORITEMS'[$PIECE(DATA(NUM),U,4)
Begin DoDot:2
+25 SET ORDATA(100.31,"+1,"_ORIEN(1)_",",.01)=$PIECE(DATA(NUM),U,4)
+26 SET ORITEMS=$SELECT(ORITEMS="":$PIECE(DATA(NUM),U,4),1:ORITEMS_U_$PIECE(DATA(NUM),U,4))
End DoDot:2
+27 IF +$DATA(ORDATA)
DO UPDATE^DIE("","ORDATA",,"ORMSG")
IF +$DATA(ORMSG)
QUIT
End DoDot:1
+28 ; get order checks
+29 SET NUM=0
FOR
SET NUM=$ORDER(CHECKS(NUM))
if '+NUM
QUIT
Begin DoDot:1
+30 NEW DATA,IEN,ORXTRA
+31 SET ORDATA(100.32,"+1,"_ORIEN(1)_",",.01)=$PIECE(CHECKS(NUM),U,2)
+32 SET ORDATA(100.32,"+1,"_ORIEN(1)_",",.02)=$PIECE(CHECKS(NUM),U,3)
+33 SET ORDATA(100.32,"+1,"_ORIEN(1)_",",1)=$PIECE(CHECKS(NUM),U,4)
+34 ; check for extra data
IF ORDATA(100.32,"+1,"_ORIEN(1)_",",1)["||"
Begin DoDot:2
+35 SET ORXTRA=$PIECE($PIECE(ORDATA(100.32,"+1,"_ORIEN(1)_",",1),"||",2),"&")
+36 SET ORDATA(100.32,"+1,"_ORIEN(1)_",",1)=$PIECE(ORDATA(100.32,"+1,"_ORIEN(1)_",",1),"&",2)
+37 DO GETXTRA^ORCHECK(.DATA,ORXTRA,ORDATA(100.32,"+1,"_ORIEN(1)_",",1))
End DoDot:2
+38 DO UPDATE^DIE("","ORDATA","IEN","ORMSG")
IF +$DATA(ORMSG)
QUIT
+39 DO WP^DIE(100.32,IEN(1)_","_ORIEN(1)_",",2,,"DATA","ORMSG")
IF +$DATA(ORMSG)
QUIT
End DoDot:1
+40 ; set raw order data
+41 DO WP^DIE(100.3,ORIEN(1)_",",3,,"DATA","ORMSG")
+42 ; set xtmp to find entries to be removed (#100.03) if order is initially accepted
+43 IF '+ORIEN(1)
QUIT
+44 SET ^XTMP("ORCHECK-"_DUZ,0)=$$FMADD^XLFDT($$DT^XLFDT,1)_U_$$DT^XLFDT
+45 SET ^XTMP("ORCHECK-"_DUZ,$JOB,DFN,$$DT^XLFDT,ORIEN(1))=ORITEMS
+46 QUIT
DELORC(ORVP,ORDIALOG) ; delete order checks from 100.3/avoid duplication in 100 & 100.05
+1 NEW LOC
SET LOC=$NAME(ORDIALOG)
SET ORVP=+ORVP
+2 IF '+$DATA(^XTMP("ORCHECK-"_DUZ))
QUIT
+3 NEW JOB,ORCHECK,ORITEMS,ORDT,NUM
+4 SET JOB=$JOB
SET ORDT=$$DT^XLFDT
+5 ; get most recent IEN from 100.3 for the given user,job,patient,date
SET ORCHECK=""
SET ORCHECK=$ORDER(^XTMP("ORCHECK-"_DUZ,JOB,ORVP,ORDT,ORCHECK),-1)
+6 IF '+ORCHECK
QUIT
+7 SET NUM=0
SET ORITEMS=""
FOR
SET NUM=$ORDER(@LOC@(4,NUM))
if '+NUM
QUIT
Begin DoDot:1
+8 ; get all orderable items
SET ORITEMS=$SELECT(ORITEMS="":@LOC@(4,NUM),1:ORITEMS_U_@LOC@(4,NUM))
End DoDot:1
+9 IF ORITEMS=^XTMP("ORCHECK-"_DUZ,JOB,ORVP,ORDT,ORCHECK)
Begin DoDot:1
+10 ; remove entry from 100.3
NEW DA,DIK
SET DIK="^OR(100.3,"
SET DA=ORCHECK
DO ^DIK
+11 ; remove xtmp data
KILL ^XTMP("ORCHECK-"_DUZ,JOB,ORVP)
End DoDot:1
+12 QUIT
ORCAN(ORIEN,OCC) ; order has been cancelled/changed after acceptance
+1 NEW ORCHK
+2 ; quit if no order checks for the order
DO GETOC2^OROCAPI1(+ORIEN,.ORCHK)
IF '+$DATA(ORCHK)
QUIT
+3 NEW ORDATA,ORMSG
+4 SET ORDATA(100.3,"+1,",.01)=$$NOW^XLFDT
+5 SET ORDATA(100.3,"+1,",.02)=$GET(DFN)
+6 SET ORDATA(100.3,"+1,",.03)=DUZ
+7 SET ORDATA(100.3,"+1,",.05)=OCC
+8 SET ORDATA(100.3,"+1,",.07)=+ORIEN
+9 DO UPDATE^DIE("","ORDATA","ORIEN","ORMSG")
IF +$DATA(ORMSG)
QUIT
+10 ; get orderable items
Begin DoDot:1
+11 NEW DATA,IEN
DO GETS^DIQ(100,ORIEN,".1*","I","DATA")
+12 SET IEN=""
FOR
SET IEN=$ORDER(DATA(100.001,IEN))
if '+IEN
QUIT
Begin DoDot:2
+13 NEW ORDATA
SET ORDATA(100.31,"+1,"_ORIEN(1)_",",.01)=DATA(100.001,IEN,.01,"I")
+14 DO UPDATE^DIE("","ORDATA","","ORMSG")
End DoDot:2
End DoDot:1
+15 SET ORCHK=0
FOR
SET ORCHK=$ORDER(ORCHK(ORIEN,ORCHK))
if '+ORCHK
QUIT
Begin DoDot:1
+16 NEW DATA,IEN,ORDATA
DO GETS^DIQ(100.05,ORCHK_",","5;6;8","I","DATA")
+17 SET ORDATA(100.32,"+1,"_ORIEN(1)_",",.01)=DATA(100.05,ORCHK_",",5,"I")
+18 SET ORDATA(100.32,"+1,"_ORIEN(1)_",",.02)=DATA(100.05,ORCHK_",",6,"I")
+19 SET ORDATA(100.32,"+1,"_ORIEN(1)_",",1)=DATA(100.05,ORCHK_",",8,1)
+20 DO UPDATE^DIE("","ORDATA","","ORMSG")
End DoDot:1
+21 QUIT
EN ; main entry for creating a delimited report via HOST FILE or displaying CANCELLED ORDERS via ListManager
+1 WRITE @IOF
+2 NEW CONT,LOC,POP,SRCH,X,Y
+3 ; set global location of entries
SET CONT=0
SET LOC=$NAME(^TMP("ORCHK",$JOB))
KILL @LOC
+4 ; setup search parameters from user
DO SETUP(.SRCH)
+5 IF '+CONT
WRITE !!,"Search parameter entry aborted.",!
QUIT
+6 ; find entries that match search criteria
DO FIND(.SRCH,LOC)
+7 IF +$DATA(SRCH("DLM"))
Begin DoDot:1
+8 NEW %ZIS,DSC,IOP,POP,RTN,ZTSAVE,ZTSK
+9 SET ZTSAVE("JOB")=""
SET ZTSAVE("SRCH")=""
SET ZTSAVE("LOC")=""
+10 ;,%ZIS("HFSNAME")=SRCH("DLM"),IOP="Q;HFS"
SET %ZIS="Q"
+11 SET DSC="Cancelled Order Report"
SET RTN="REPORT^ORNORC(LOC)"
+12 WRITE !
DO EN^XUTMDEVQ(RTN,DSC,.ZTSAVE,.%ZIS,1)
+13 IF +$GET(ZTSK)
WRITE !!,"Task #",ZTSK
End DoDot:1
QUIT
+14 ; start ListManager
+15 DO EN^OROCLM(.SRCH,LOC)
+16 KILL @LOC
+17 QUIT
SETUP(SRCH) ; user required input for search parameters
+1 NEW DIR,POP,SRCHCRIT,X,Y
+2 SET DIR(0)="S^LM:ListManager;DLM:Delmited Data Host File"
+3 SET DIR("A")="LM/DLM"
SET DIR("B")="LM"
+4 SET DIR("L",1)="Select which type of data output: "
+5 SET DIR("L",2)=""
+6 SET DIR("L",3)=" LM ListManager Display"
+7 SET DIR("L")=" DLM Delimited Data via Host File"
+8 WRITE !
DO ^DIR
IF Y'["LM"
QUIT
+9 ; D
IF Y="DLM"
SET SRCH("DLM")=1
+10 ;. S SRCH("DLM")=$$DEFDIR^%ZISH()_$$UP^XLFSTR($TR($$FMTE^XLFDT(DT,8)," ","_"))_"_ORDER_CHECK_REPORT.CSV"
+11 ;. W !!,"Your report will be located:",!!,$P(SRCH("DLM"),U),$P(SRCH("DLM"),U,2)
LM ;
+1 ; get a date range from user
Begin DoDot:1
+2 NEW %DT,DIR,X,Y
SET %DT(0)=-$$DT^XLFDT
SET %DT="AEX"
SET %DT("A")="Select Beginning DATE: "
SET %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30))
+3 WRITE !
DO ^%DT
KILL %DT
if Y<0
QUIT
SET SRCH("ADATE")=Y
+4 SET DIR("A")=" Ending DATE: "
SET DIR("B")="TODAY"
SET DIR(0)="DA"_U_SRCH("ADATE")_":"_$$DT^XLFDT_":EX"
+5 SET DIR("?",1)="Enter a date between "_$$FMTE^XLFDT(SRCH("ADATE"))_" and "_$$FMTE^XLFDT($$DT^XLFDT)_"."
SET DIR("?")=" "
+6 WRITE !
DO ^DIR
if Y'>0
QUIT
SET SRCH("BDATE")=Y
End DoDot:1
IF '+$DATA(SRCH("ADATE"))!'+$DATA(SRCH("BDATE"))
QUIT
+7 ;
+8 SET DIR(0)="YA"
SET DIR("A")="Would you like to select additional SEARCH CRITERIA? "
SET DIR("B")="NO"
+9 WRITE !
DO ^DIR
IF '+Y
SET CONT=$SELECT(+$GET(DIRUT):0,+$GET(DUOUT):0,1:1)
QUIT
+10 ;
+11 SET SRCHCRIT=$$SRCHCRIT(.SRCHCRIT,"A","OCCURRENCE","ORCHK SRCHPARAM 1 MAIN MENU","Enter search criteria: ")
if SRCHCRIT=-1
QUIT
+12 SET CONT=1
FOR X=1:1:SRCHCRIT
Begin DoDot:1
+13 IF SRCHCRIT(X)["LOCATION"
Begin DoDot:2
+14 WRITE !
SET SRCH("LOCATION")=$$FLU(44)
End DoDot:2
IF SRCH("LOCATION")=-1
SET X=SRCHCRIT
SET CONT=0
QUIT
+15 IF SRCHCRIT(X)["OCCURRENCE"
Begin DoDot:2
+16 NEW SRCHCRIT,X
SET SRCHCRIT=$$SRCHCRIT(.SRCHCRIT,"A","CANCELLED","ORCHK SRCHPARAM 2 OCCURRENCE MENU","Enter OCCURRENCE(S): ")
if SRCHCRIT=-1
QUIT
+17 SET SRCH("OCCURRENCE")=""
FOR X=1:1:SRCHCRIT
Begin DoDot:3
+18 SET SRCH("OCCURRENCE")=SRCH("OCCURRENCE")_$SELECT($PIECE(SRCHCRIT(X),U,3)="CANCELLED":"C",$PIECE(SRCHCRIT(X),U,3)="ACCEPTED/CANCELLED":"AC",1:"RT")_$SELECT(SRCHCRIT=X:"",1:U)
End DoDot:3
End DoDot:2
IF '+$DATA(SRCH("OCCURRENCE"))
SET SRCH("OCCURRENCE")=-1
SET X=SRCHCRIT
SET CONT=0
QUIT
+19 IF SRCHCRIT(X)["PATIENT"
Begin DoDot:2
+20 WRITE !
SET SRCH("PATIENT")=$$FLU(2)
End DoDot:2
IF SRCH("PATIENT")=-1
SET X=SRCHCRIT
SET CONT=0
QUIT
+21 IF SRCHCRIT(X)["USER"
Begin DoDot:2
+22 WRITE !
SET SRCH("USER")=$$FLU(200)
End DoDot:2
IF SRCH("USER")=-1
SET X=SRCHCRIT
SET CONT=0
QUIT
+23 IF SRCHCRIT(X)["ORDERABLE ITEM"
Begin DoDot:2
+24 WRITE !
SET SRCH("ORDITEM")=$$FLU(101.43)
End DoDot:2
IF SRCH("ORDITEM")=-1
SET X=SRCHCRIT
SET CONT=0
QUIT
+25 IF SRCHCRIT(X)["ORDER CHECK"
Begin DoDot:2
+26 WRITE !
SET SRCH("ORDCHECK")=$$FLU(100.8)
End DoDot:2
IF SRCH("ORDCHECK")=-1
SET X=SRCHCRIT
SET CONT=0
QUIT
+27 IF SRCHCRIT(X)["CLINICAL DANGER LEVEL"
Begin DoDot:2
+28 NEW SRCHCRIT,X
SET SRCHCRIT=$$SRCHCRIT(.SRCHCRIT,"A","HIGH","ORCHK SRCHPARAM 3 DANGER MENU","Enter CLINICAL DANGER LEVEL: ")
IF SRCHCRIT=-1
SET CONT=0
QUIT
+29 SET SRCH("CDL")=""
FOR X=1:1:SRCHCRIT
Begin DoDot:3
+30 SET SRCH("CDL")=SRCH("CDL")_$SELECT($PIECE(SRCHCRIT(X),U,3)="HIGH":"1",$PIECE(SRCHCRIT(X),U,3)="MEDIUM":"2",1:"3")_$SELECT(SRCHCRIT=X:"",1:U)
End DoDot:3
End DoDot:2
IF '+$DATA(SRCH("CDL"))
SET SRCH("CDL")=-1
SET X=SRCHCRIT
SET CONT=0
QUIT
End DoDot:1
+31 QUIT
FIND(SRCH,LOC) ;
+1 NEW BDT,GBL,IEN
SET IEN=0
SET GBL=$NAME(^OR(100.3))
+2 FOR BDT=SRCH("ADATE"):1:SRCH("BDATE")
SET IEN=0
FOR
SET IEN=$ORDER(@GBL@("B",BDT,IEN))
if '+IEN
QUIT
Begin DoDot:1
+3 NEW DATA,MATCH
SET MATCH=""
+4 ; CANCELLED orders are only located in File #100.3
+5 IF $GET(SRCH("OCCURRENCE"))'="C"
IF +$DATA(@GBL@("ORDER",IEN))
Begin DoDot:2
+6 NEW OIEN
SET OIEN=""
SET OIEN=$ORDER(@GBL@("ORDER",IEN,OIEN))
if '+OIEN
QUIT
Begin DoDot:3
+7 NEW DATA1,ORCHK
+8 DO GETS^DIQ(100,OIEN_",",".02;3;6;.1*","IN","DATA1")
+9 SET DATA("PATIENT")=+DATA1(100,OIEN_",",.02,"I")
SET DATA("USER")=DATA1(100,OIEN_",",3,"I")
SET DATA("LOCATION")=+DATA1(100,OIEN_",",6,"I")
+10 SET (DATA1,DATA("ORDITEM"))=""
FOR
SET DATA1=$ORDER(DATA1(100.001,DATA1))
if '+DATA1
QUIT
Begin DoDot:4
+11 SET DATA("ORDITEM")=DATA("ORDITEM")_DATA1(100.001,DATA1,.01,"I")_$SELECT(+$ORDER(DATA1(100.001,DATA1)):U,1:"")
End DoDot:4
+12 DO GETOC2^OROCAPI1(OIEN,.ORCHK)
+13 SET (DATA("ORDCHECK"),DATA("CDL"),ORCHK)=""
FOR
SET ORCHK=$ORDER(ORCHK(OIEN,ORCHK))
if '+ORCHK
QUIT
Begin DoDot:4
+14 DO GETS^DIQ(100.05,ORCHK_",","5;6","IN","DATA1")
+15 SET DATA("ORDCHECK")=DATA("ORDCHECK")_DATA1(100.05,ORCHK_",",5,"I")_$SELECT(+$ORDER(ORCHK(OIEN,ORCHK)):U,1:"")
+16 SET DATA("CDL")=DATA("CDL")_DATA1(100.05,ORCHK_",",6,"I")_$SELECT(+$ORDER(ORCHK(OIEN,ORCHK)):U,1:"")
End DoDot:4
End DoDot:3
End DoDot:2
+17 SET SRCH="BDATE"
FOR
SET SRCH=$ORDER(SRCH(SRCH))
if SRCH=""
QUIT
Begin DoDot:2
+18 ; not a search parameter
IF SRCH="DLM"
QUIT
+19 SET MATCH=MATCH_$$MATCH(SRCH,SRCH(SRCH),$GET(DATA(SRCH)))_U
End DoDot:2
+20 ; if no failed search parameters, it's a match
IF +$LENGTH(MATCH,U)=1
SET MATCH=1
+21 IF MATCH[0
QUIT
+22 SET @LOC@(IEN)=""
End DoDot:1
+23 QUIT
MATCH(INDEX,SRCHCRIT,DATA) ;
+1 IF SRCHCRIT=DATA
QUIT 1
+2 IF +$DATA(@GBL@(INDEX,SRCH(INDEX),IEN))
QUIT 1
+3 NEW X,Y
SET Y=0
+4 IF INDEX="CDL"
FOR X=1:1:$LENGTH(SRCHCRIT,U)
Begin DoDot:1
+5 IF +$DATA(@GBL@(INDEX,$PIECE(SRCHCRIT,U,X),IEN))
SET Y=1
QUIT
+6 IF DATA[$PIECE(SRCHCRIT,U,X)
SET Y=1
End DoDot:1
+7 IF INDEX="OCCURRENCE"
FOR X=1:1:$LENGTH(SRCHCRIT,U)
IF +$DATA(@GBL@(INDEX,$PIECE(SRCHCRIT,U,X),IEN))
SET Y=1
QUIT
+8 IF INDEX="ORDCHECK"!(INDEX="ORDITEM")
FOR X=1:1:$LENGTH(DATA)
Begin DoDot:1
+9 IF $PIECE(DATA,U,X)=SRCHCRIT
SET Y=1
QUIT
End DoDot:1
+10 QUIT Y
FLU(FILE) ; file lookup
+1 NEW DIC,FINFO,X,Y
+2 DO FILE^DID(FILE,,"NAME;GLOBAL NAME","FINFO")
+3 SET DIC=FINFO("GLOBAL NAME")
SET DIC(0)="AEMQ"
SET DIC("A")="Select "_FINFO("NAME")_": "
+4 DO ^DIC
+5 QUIT +Y
SRCHCRIT(Y,PARAM,DEFAULT,MENU,PROMPT) ; get search criteria using menu & actions from the protocol file
+1 NEW I,X,XQORM
+2 SET XQORM=+$ORDER(^ORD(101,"B",MENU,0))_";ORD(101,"
+3 IF '+XQORM
QUIT "-1^Menu entry not found."
+4 SET XQORM(0)=$GET(PARAM)
SET XQORM("A")=PROMPT
SET XQORM("B")=DEFAULT
+5 DO EN^XQORM
+6 QUIT $GET(Y)
REPORT(LOC) ; writes the data for the host file(s)
+1 ; set sequence for fields
NEW FCNT,FLDORD,IEN,IOM,SEQ
SET IOM=9999
SET SEQ=0
+2 ; set delimiter for report
NEW DELIM
SET DELIM=","
+3 ;
+4 ; Call FILEDD(<file#>) and S FCNT(SEQ,X)=FCNT for each FILE to be in the host file
+5 ; FCNT is the total field count for each file for displaying FILE info above headers
+6 ;
+7 NEW X
FOR X=100.3,100,100.05
SET FCNT=0
DO FILEDD(X)
SET FCNT(SEQ,X)=FCNT
+8 ;
+9 DO HDR
KILL FLDORD
+10 SET IEN=0
FOR
SET IEN=$ORDER(@LOC@(IEN))
if '+IEN
QUIT
Begin DoDot:1
+11 NEW ORDER,ORCHK
+12 ; main entry from File #100.3
DO GODATA(100.3,IEN,1)
+13 SET ORDER=+$$GET1^DIQ(100.3,IEN,.07)
IF +ORDER
Begin DoDot:2
+14 ; main entry from File #100 (ORDER) - one ORDER per CANCELLED ORDER (#100.3)
DO GODATA(100,ORDER)
+15 ; get order checks for the ORDER
DO GETOC2^OROCAPI1(ORDER,.ORCHK)
+16 NEW CNT
SET CNT=0
SET ORCHK=""
FOR
SET ORCHK=$ORDER(ORCHK(ORDER,ORCHK))
if '+ORCHK
QUIT
Begin DoDot:3
+17 ; the main entry from File #100.05 (ORDER CHECK INSTANCES) - one or more per ORDER
+18 SET CNT=CNT+1
IF CNT=1
DO GODATA(100.05,ORCHK)
WRITE $CHAR(182)
QUIT
+19 ; multi line results for an ORDER need "blank" entries for each file that precedes it
+20 DO GODATA(100.3,,1)
DO GODATA(100)
DO GODATA(100.05,ORCHK)
WRITE $CHAR(182)
End DoDot:3
End DoDot:2
QUIT
+21 WRITE $CHAR(182)
End DoDot:1
+22 KILL @LOC
+23 QUIT
GODATA(FILE,IEN,STRT) ; get and output the file data
+1 NEW DATA,FLDORD
+2 NEW FN,FLD
+3 IF +$GET(FILE)
IF +$GET(IEN)
SET IEN=IEN_","
DO GETS^DIQ(FILE,IEN,"**","N","DATA")
+4 if +$GET(STRT)
WRITE !
if '+$GET(STRT)
WRITE ","
+5 DO FILEDD(FILE)
+6 SET (SEQ,FN,FLD)=0
FOR
SET SEQ=$ORDER(FLDORD(SEQ))
if '+SEQ
QUIT
FOR
SET FN=$ORDER(FLDORD(SEQ,FN))
if '+FN
QUIT
FOR
SET FLD=$ORDER(FLDORD(SEQ,FN,FLD))
if '+FLD
QUIT
Begin DoDot:1
+7 NEW CNT,SIEN
SET (CNT,SIEN)=""
+8 FOR
SET SIEN=$ORDER(DATA(FN,SIEN))
if '+SIEN
QUIT
Begin DoDot:2
+9 IF +$DATA(DATA(FN,SIEN,FLD))
Begin DoDot:3
+10 SET CNT=CNT+1
+11 if CNT=1
WRITE $CHAR(34)
+12 IF $$GET1^DID(FN,FLD,,"TYPE")="WORD-PROCESSING"
Begin DoDot:4
+13 NEW NUM
SET NUM=0
FOR
SET NUM=$ORDER(DATA(FN,SIEN,FLD,NUM))
if '+NUM
QUIT
Begin DoDot:5
+14 WRITE $$QM(DATA(FN,SIEN,FLD,NUM))
if +$ORDER(DATA(FN,SIEN,FLD,NUM))
WRITE !
End DoDot:5
End DoDot:4
+15 if $$GET1^DID(FN,FLD,,"TYPE")'="WORD-PROCESSING"
WRITE $$QM(DATA(FN,SIEN,FLD))
+16 if +$ORDER(DATA(FN,SIEN))
WRITE !
End DoDot:3
End DoDot:2
+17 IF +CNT
Begin DoDot:2
+18 WRITE $CHAR(34)
+19 IF +$ORDER(FLDORD($SELECT($$GET1^DID(FN,FLD,,"TYPE")="WORD-PROCESSING":(SEQ+1),1:SEQ)))
WRITE DELIM
QUIT
End DoDot:2
QUIT
+20 IF '+CNT
Begin DoDot:2
+21 IF +FLDORD(SEQ,FN,FLD)
IF $$GET1^DID(FN,FLD,,"TYPE")="WORD-PROCESSING"
Begin DoDot:3
+22 WRITE $$QM("")
+23 IF +$ORDER(FLDORD((SEQ+1)))
WRITE DELIM
QUIT
End DoDot:3
+24 IF '+FLDORD(SEQ,FN,FLD)
IF $$GET1^DID(FN,FLD,,"TYPE")'="WORD-PROCESSING"
Begin DoDot:3
+25 WRITE $$QM("")
+26 IF +$ORDER(FLDORD(SEQ))
WRITE DELIM
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
FILEDD(FILENUM) ; establishes file/field sequence via the data dictionary ; IA #999
+1 ; FCNT,SEQ must be set prior to calling
+2 NEW NODE,PIECE,FLD
SET (NODE,PIECE,FLD)=""
+3 IF +$DATA(^DD(FILENUM,"GL"))
FOR
SET NODE=$ORDER(^DD(FILENUM,"GL",NODE))
if NODE=""
QUIT
FOR
SET PIECE=$ORDER(^DD(FILENUM,"GL",NODE,PIECE))
if PIECE=""
QUIT
FOR
SET FLD=$ORDER(^DD(FILENUM,"GL",NODE,PIECE,FLD))
if '+FLD
QUIT
Begin DoDot:1
+4 NEW NODE0
SET NODE0=$GET(^DD(FILENUM,FLD,0))
+5 IF +$PIECE(NODE0,U,2)
Begin DoDot:2
+6 SET SEQ=SEQ+1
SET FLDORD(SEQ,FILENUM,FLD)=+$PIECE(NODE0,U,2)
+7 DO FILEDD(+$PIECE(NODE0,U,2))
End DoDot:2
QUIT
+8 SET FCNT=FCNT+1
SET SEQ=SEQ+1
SET FLDORD(SEQ,FILENUM,FLD)=""
End DoDot:1
+9 QUIT
HDR ; write field names for the column headers
+1 NEW CNT,FILE,X
+2 SET CNT=1
SET (FCNT,FILE)=""
FOR
SET FCNT=$ORDER(FCNT(FCNT))
if '+FCNT
QUIT
FOR
SET FILE=$ORDER(FCNT(FCNT,FILE))
if '+FILE
QUIT
Begin DoDot:1
+3 NEW NAME
DO FILE^DID(FILE,,"NAME","NAME")
+4 SET CNT=CNT+FCNT(FCNT,FILE)
+5 SET $PIECE(X,DELIM,(CNT-FCNT(FCNT,FILE)))="File #"_FILE_" ["_NAME("NAME")_"]"
End DoDot:1
+6 WRITE X,!
+7 ;
+8 NEW SEQ,FN,FLD
+9 SET (SEQ,FN,FLD)=0
FOR
SET SEQ=$ORDER(FLDORD(SEQ))
if '+SEQ
QUIT
FOR
SET FN=$ORDER(FLDORD(SEQ,FN))
if '+FN
QUIT
FOR
SET FLD=$ORDER(FLDORD(SEQ,FN,FLD))
if '+FLD
QUIT
Begin DoDot:1
+10 ; not a multiple
IF '+FLDORD(SEQ,FN,FLD)
Begin DoDot:2
+11 ; field data & delim
WRITE $$QM($$GET1^DID(FN,FLD,,"LABEL"),1)
IF +$ORDER(FLDORD(SEQ))
WRITE DELIM
End DoDot:2
QUIT
End DoDot:1
+12 QUIT
QM(DATA,QM) ; for excel importing as csv, replace a single double quote with two double quotes
+1 IF DATA[$CHAR(34)
NEW X
SET X("""")=""""""
SET DATA=$$REPLACE^XLFSTR(DATA,.X)
+2 QUIT $SELECT(+$GET(QM):$CHAR(34)_DATA_$CHAR(34),1:DATA)
