Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM

Timestamp:

Dec 4, 2009, 12:11:15 AM (15 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

Location:

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM

Files:

• PXRM7M1.m (modified) (1 diff)
• PXRM7XT.m (modified) (1 diff)
• PXRMCDUE.m (modified) (1 diff)
• PXRMCF.m (modified) (1 diff)
• PXRMCOND.m (modified) (1 diff)
• PXRMCOPY.m (modified) (1 diff)
• PXRMDATA.m (modified) (1 diff)
• PXRMDATE.m (modified) (1 diff)
• PXRMDBL3.m (modified) (1 diff)
• PXRMDEDT.m (modified) (1 diff)
• PXRMDEV.m (modified) (1 diff)
• PXRMDLG4.m (modified) (1 diff)
• PXRMDLG5.m (modified) (1 diff)
• PXRMDLGZ.m (modified) (1 diff)
• PXRMDLL.m (modified) (1 diff)
• PXRMDLLA.m (modified) (1 diff)
• PXRMDLLB.m (modified) (1 diff)
• PXRMDLR.m (modified) (1 diff)
• PXRMDLR1.m (modified) (1 diff)
• PXRMDNVA.m (modified) (1 diff)
• PXRMDRGR.m (modified) (1 diff)
• PXRMDRUG.m (modified) (1 diff)
• PXRMEDIT.m (modified) (1 diff)
• PXRMENOD.m (modified) (1 diff)
• PXRMEPM.m (modified) (1 diff)
• PXRMETCO.m (modified) (1 diff)
• PXRMETH.m (modified) (1 diff)
• PXRMETH1.m (modified) (1 diff)
• PXRMETM.m (modified) (1 diff)
• PXRMETT.m (modified) (1 diff)
• PXRMETX.m (modified) (1 diff)
• PXRMETXR.m (modified) (1 diff)
• PXRMETXU.m (modified) (1 diff)
• PXRMEUT.m (modified) (1 diff)
• PXRMEUT1.m (modified) (1 diff)
• PXRMEVFI.m (modified) (1 diff)
• PXRMEXCF.m (modified) (1 diff)
• PXRMEXCS.m (modified) (1 diff)
• PXRMEXDG.m (modified) (1 diff)
• PXRMEXFI.m (modified) (1 diff)
• PXRMEXID.m (modified) (1 diff)
• PXRMEXIU.m (modified) (1 diff)
• PXRMEXIX.m (modified) (1 diff)
• PXRMEXLB.m (modified) (1 diff)
• PXRMEXLC.m (modified) (1 diff)
• PXRMEXLD.m (modified) (1 diff)
• PXRMEXLI.m (modified) (1 diff)
• PXRMEXLM.m (modified) (1 diff)
• PXRMEXLR.m (modified) (1 diff)
• PXRMEXPR.m (modified) (1 diff)
• PXRMEXPU.m (modified) (1 diff)
• PXRMEXSI.m (modified) (1 diff)
• PXRMEXU1.m (modified) (1 diff)
• PXRMEXU2.m (modified) (1 diff)
• PXRMEXU4.m (modified) (1 diff)
• PXRMFF.m (modified) (1 diff)
• PXRMFF0.m (modified) (1 diff)
• PXRMFFAT.m (modified) (1 diff)
• PXRMFFDB.m (modified) (1 diff)
• PXRMGECN.m (modified) (1 diff)
• PXRMHF.m (modified) (1 diff)
• PXRMINDC.m (modified) (1 diff)
• PXRMINDD.m (modified) (1 diff)
• PXRMINDL.m (modified) (1 diff)
• PXRMINDX.m (modified) (1 diff)
• PXRMISE.m (modified) (1 diff)
• PXRMLCD.m (modified) (1 diff)
• PXRMLCR.m (modified) (1 diff)
• PXRMLIST.m (modified) (1 diff)
• PXRMLLED.m (modified) (1 diff)
• PXRMLOCF.m (modified) (1 diff)
• PXRMLOCL.m (modified) (1 diff)
• PXRMLPAU.m (modified) (1 diff)
• PXRMLPHS.m (modified) (1 diff)
• PXRMLPP.m (modified) (1 diff)
• PXRMLPU.m (modified) (1 diff)
• PXRMLRM.m (modified) (1 diff)
• PXRMMH.m (modified) (1 diff)
• PXRMMST.m (modified) (1 diff)
• PXRMOUTC.m (modified) (1 diff)
• PXRMOUTM.m (modified) (1 diff)
• PXRMPARS.m (modified) (1 diff)
• PXRMPDR.m (modified) (1 diff)
• PXRMPDRP.m (modified) (1 diff)
• PXRMPDRS.m (modified) (1 diff)
• PXRMPLST.m (modified) (1 diff)
• PXRMPTD2.m (modified) (1 diff)
• PXRMPTDF.m (modified) (1 diff)
• PXRMPTTR.m (modified) (1 diff)
• PXRMREDF.m (modified) (1 diff)
• PXRMREDT.m (modified) (1 diff)
• PXRMRPCC.m (modified) (1 diff)
• PXRMRUL1.m (modified) (1 diff)
• PXRMRULE.m (modified) (1 diff)
• PXRMSTA1.m (modified) (1 diff)
• PXRMSTA2.m (modified) (1 diff)
• PXRMSXRM.m (modified) (1 diff)
• PXRMTAX.m (modified) (1 diff)
• PXRMTERM.m (modified) (1 diff)
• PXRMTEXT.m (modified) (1 diff)
• PXRMTMED.m (modified) (1 diff)
• PXRMUTIL.m (modified) (1 diff)
• PXRMVITL.m (modified) (1 diff)
• PXRMVPTR.m (modified) (1 diff)
• PXRMVSIT.m (modified) (1 diff)
• PXRMXD.m (modified) (1 diff)
• PXRMXDT1.m (modified) (1 diff)
• PXRMXGPR.m (modified) (1 diff)
• PXRMXGUT.m (modified) (1 diff)
• PXRMXPR.m (modified) (1 diff)
• PXRMXPR1.m (modified) (1 diff)
• PXRMXQUE.m (modified) (1 diff)
• PXRMXSC.m (modified) (1 diff)
• PXRMXSE1.m (modified) (1 diff)
• PXRMXSL1.m (modified) (1 diff)
• PXRMXSL2.m (modified) (1 diff)
• PXRMXTB.m (modified) (1 diff)
• PXRMXTD.m (modified) (1 diff)
• PXRMXTE.m (modified) (1 diff)
• PXRMXTF.m (modified) (1 diff)
• PXRMXTU.m (modified) (1 diff)

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m

@@ -1 @@
-PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 06/01/2007  15:26
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;This routine will use the HL7 Package commands to gather the message
-        ;into the file 772
-        Q
-EN(ID)  ;Entry Point
-        ;
-        S (PROTIEN,PXRM7,PXRM7R,PXRM77,PXRM7ID)=""
-        S PROTIEN=$O(^ORD(101,"B","PXRM7 RECO SERVER",PROTIEN))
-        S HL("EID")=PROTIEN
-        D INIT^HLFNC2(PROTIEN,.PXRM7)
-        S PXRM7("PID")="HI^D"
-        S HLA("HLS",1)=PXRM77
-        D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,)
-        D STORE^PXRM7API
-        S ID=ZMID
-        Q
+PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 03/21/2002 ;4/11/02  15:26
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;This routine will use the HL7 Package commands to gather the message
+ ;into the file 772
+ Q
+EN(ID) ;Entry Point
+ ;
+ S (PROTIEN,PXRM7,PXRM7R,PXRM77,PXRM7ID)=""
+ S PROTIEN=$O(^ORD(101,"B","PXRM7 RECO SERVER",PROTIEN))
+ S HL("EID")=PROTIEN
+ D INIT^HLFNC2(PROTIEN,.PXRM7)
+ S PXRM7("PID")="HI^D"
+ S HLA("HLS",1)=PXRM77
+ D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,)
+ S ID=ZMID
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m

@@ -1 @@
-PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 06/01/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;This is the beginning of the extraction from the extract file
-        ;
-        ;VARIABLE LIST
-        ;IEN = IEN OF ENTRY IN EXTRACT FILE 810.3
-        Q
-SPLIT   ;SPLIT MESSAGES
-        ;
-        N ORC2
-        I LINE>100 D
-        .S ORCCNT=ORCCNT+1
-        .D EN^PXRM7M1(.ID)
-        .K ^TMP("HLS",$J)
-        .S ORC2=$G(^TMP("PXRM7HLORC",$J))
-        .S $P(ORC2,"|",3)="P"_ORCCNT,ORC=ORC2
-        .S LINE=2
-        .I $D(SEE) W !,ORC
-        .S ^TMP("HLS",$J,1)=ORC
-        Q
-        ;
-EXTRACT(IEN,SEE,ID,MODE)        ;
-        N ORCCNT
-        K ERROR,LINE
-        S ORCCNT=1  ;Count of ORC segments or number of messages created
-        S LINE=1 ;Line count for the ^TMP("HL7",$J,LINE) global variable
-        ;-Verify Values
-        I '$D(^PXRMXT(810.3,IEN)) S ERROR(1)="No Such IEN in file 810.3 "_IEN
-        I $D(ERROR) D  Q
-        .I $D(SEE)=1
-        ;-Extracting Value of Nodes in file
-        I $D(ERROR) Q
-        D GETS^DIQ(810.3,IEN,"**","EI","^TMP(""PXRM7"",$J)")
-        D ORCSEG
-        ;******Add NTE segment to end of message *******
-        ;******change 3rd piece of ORC segement to L (last)****
-        S NTE="NTE||"_LAST_"||"
-        S ^TMP("HLS",$J,LINE)=NTE,LINE=LINE+1
-        I SEE=1 W !,NTE
-        K NTE,LAST
-        S ORC=$G(^TMP("HLS",$J,1)),$P(ORC,"|",3)="F"_ORCCNT,^TMP("HLS",$J,1)=ORC
-        ;***********************************************
-        ;*******TURN ON BELOW TO TRANSMIT TO AUSTIN *****
-        D EN^PXRM7M1(.ID)
-        ;***********************************************
-        K ^TMP("PXRM7",$J)
-        K ^TMP("HLS",$J)
-        K ^TMP("PXRM7HLORC",$J)
-        ;********KILL LEFT OVER ARRAYS AND VARIABLES*****
-        K HL("EID"),HLA("HLS"),PROTIEN,PXRM7,PXRM77,PXRM7ID,PXRM7R,ZMID
-        K DA,DISYS,DISYS,EO,HL("EIDS"),HLECH,HLFS,HLN,HLQ,HLSAN,HLX
-        K IENIEN,IENOBR,IENX,IENY,IENZ,L,LINE,NEXT,QTI,RFS,SEQ
-        K STATION,USI
-        ;**************************************************
-        Q
-ORCSEG  ;CREATE ORC SEGMENTS
-        ;ORDERED IN ORDER OF APPEARANCE IN SEGMENT
-        ;QTI=QUANTITY AND TIMING
-        ;EO=ENTERING ORGANIZATION
-        ;--Below adds extra line feed in front of the message. --
-        ;---------------------------------------------------
-        S IENY=IEN_","
-        ;---------------------------------------------
-        ;0 PLACER ORDER NUMBER      ORC.2.1
-        S $P(ORC,"|",3)="P1"
-        ;---------------------------------------------
-        ;1 REPORTING PERIOD         ORC.7.1.1
-        S QTI(1)=$G(^TMP("PXRM7",$J,810.3,IENY,3,"E"))
-        S $P(QTI,"~",1)=QTI(1)
-        ;---------------------------------------------
-        ;2 QUARTER                  ORC.7.3
-        S QTI(3)=$G(^TMP("PXRM7",$J,810.3,IENY,7,"E"))
-        S $P(QTI,"~",3)=QTI(3)
-        ;---------------------------------------------
-        ;3 BEGINNING DATE           ORC.7.4.1
-        S QTI(4)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.02,"I")),"DT")
-        S $P(QTI,"~",4)=QTI(4)
-        ;---------------------------------------------
-        ;4 ENDING DATE              ORC.7.5.1
-        S QTI(5)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.03,"I")),"DT")
-        S $P(QTI,"~",5)=QTI(5)
-        ;---------------------------------------------
-        ;5 REPORTING YEAR           ORC.7.11.2
-        S QTI(11)="&"_$G(^TMP("PXRM7",$J,810.3,IENY,4,"E"))
-        S $P(QTI,"~",11)=QTI(11)
-        ;---------------------------------------------
-        ;6 EXTRACT DATE             ORC.9.1
-        S $P(ORC,"|",10)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.06,"I")),"DT")
-        ;---------------------------------------------
-        ;7 NAME                     ORC.17.2
-        S EO(2)=$G(^TMP("PXRM7",$J,810.3,IENY,.01,"E"))
-        S $P(EO,"~",2)=EO(2)
-        ;---------------------------------------------
-        ;8 REPORT EXTRACT PARAMETER ORC.17.5
-        S EO(5)=$G(^TMP("PXRM7",$J,810.3,IENY,1,"E"))
-        S $P(EO,"~",5)=EO(5)
-        ;---------------------------------------------
-        ;9 REPORT EXTRACT TYPE      ORC.18.2
-        S $P(ORC,"|",19)="~"_$G(^TMP("PXRM7",$J,810.3,IENY,2,"E"))
-        ;---------------------------------------------
-        ;FINISH POPULATING ORC SEGMENT
-        S $P(ORC,"|",8)=QTI
-        S $P(ORC,"|",18)=EO
-        S $P(ORC,"|",1)="ORC"
-        ;---------------------------------------------
-        ;SET HL7 TMP ARRAY AND SHOW SEGMENT
-        S ^TMP("HLS",$J,LINE)=ORC,LINE=LINE+1
-        I SEE=1 W !,ORC
-        S ^TMP("PXRM7HLORC",$J)=ORC
-        K ORC
-OBRSEG  ;CREATE OBR SEGMENTS
-        ;N IENOBR,SEQ,USI,QTI,NEXT,STATION
-        ;USI=UNIVERSAL SERVICE ID
-        ;RFS=REASON FOR STUDY
-        ;
-        S NEXT=1,LAST=0
-        S IENOBR=0 F  S IENOBR=$O(^PXRMXT(810.3,IEN,3,IENOBR)) Q:IENOBR<1  D
-        .S IENIEN=-1 F  S IENIEN=$O(^PXRMXT(810.3,IEN,3,IENOBR,1,IENIEN)) Q:IENIEN="B"  D  Q:IENIEN=""
-        ..S L=$S(IENIEN=0:1,IENIEN>0:2,IENIEN="":1,1:"")
-        ..;###---Set Sequence Number
-        ..S IENX=IENOBR_","_IEN_","
-        ..S IENZ=IENIEN_","_IENOBR_","_IEN_","
-        ..S SEQ=$G(^TMP("PXRM7",$J,810.33,IENX,.01,"E"))
-        ..S OBR(+SEQ_L)="OBR|1|||||||||||||||||||||||||||||||"
-        ..S $P(OBR(+SEQ_L),"|",2)=NEXT,LAST=NEXT,NEXT=NEXT+1
-        ..;--------------------------------------------------
-        ..;10 COUNT TYPE           OBR.4.2
-        ..;R=REMINDER COUNTS  F=FINDING COUNTS
-        ..S USI(2)=$S(L=1:"R",L=2:"F",1:"")
-        ..S $P(USI,"~",2)=USI(2)
-        ..;--------------------------------------------------
-        ..;11 REMINDER             OBR.4.5
-        ..S USI(5)=$G(^TMP("PXRM7",$J,810.33,IENX,.02,"E"))
-        ..S $P(USI,"~",5)=USI(5)
-        ..;--------------------------------------------------
-        ..;12 STATION              OBR.3.1
-        ..S STATION=$G(^TMP("PXRM7",$J,810.33,IENX,.03,"I"))_","
-        ..D GETS^DIQ(4,STATION,"**","E","^TMP(""PXRM7"",$J)")
-        ..S $P(OBR(+SEQ_L),"|",4)=$G(^TMP("PXRM7",$J,4,STATION,99,"E"))
-        ..;--------------------------------------------------
-        ..;13 PATIENT LIST         OBR.31.2
-        ..S RFS(2)=$G(^TMP("PXRM7",$J,810.33,IENX,.04,"E"))
-        ..S $P(RFS,"~",2)=RFS(2)
-        ..;--------------------------------------------------
-        ..;19 REMINDER TERM        OBR.31.1
-        ..S RFS(1)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.02,"E")),1:"")
-        ..S $P(RFS,"~",1)=RFS(1)
-        ..;--------------------------------------------------
-        ..;20 FINDING TOTAL TYPE   OBR.31.4
-        ..S RFS(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.03,"E")),1:"")
-        ..S $P(RFS,"~",4)=RFS(4)
-        ..;--------------------------------------------------
-        ..;21 GROUP NAME           OBR.31.5
-        ..S RFS(5)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.04,"E")),1:"")
-        ..S $P(RFS,"~",5)=RFS(5)
-        ..;--------------------------------------------------
-        ..;22 REMINDER STATUS      OBR.4.4
-        ..S USI(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.05,"I")),1:"")
-        ..S $P(USI,"~",4)=USI(4)
-        ..;-------------------------------------------------
-        ..;FINISH POPULATING OBR SEGMENT
-        ..S $P(OBR(+SEQ_L),"|",5)=USI
-        ..S $P(OBR(+SEQ_L),"|",32)=RFS
-        ..;-------------------------------------------------
-        ..;---Set message in HL7 array
-        ..;I $L($G(OBR(+SEQ_L)))=255 S OBR(+SEQ_L)=OBR(+SEQ_L)_"|||" 
-        ..S ^TMP("HLS",$J,LINE)=$G(OBR(+SEQ_L)),LINE=LINE+1
-        ..;
-        ..I SEE=1 W !," ",OBR(+SEQ_L)
-        ..K OBR
-        ..D OBXSEG
-        ..D SPLIT
-        ..I (L=1)&(IENIEN="") Q
-        Q
-OBXSEG  ;CREATE THE OBX SEGMENTS
-        N TERM
-        ;OV=OBSERVATION VALUE
-        S $P(OBX(+SEQ_L),"|",3)="MO"
-        S $P(OBX(+SEQ_L),"|",1)="OBX"
-        ;---------------------------------------------------
-        ;###---SET SEQUENCE NUMBER
-        S $P(OBX(+SEQ_L),"|",2)=1
-        ;---------------------------------------------------
-        ;14 TOTAL PATIENTS EVALUATED - REMINDER      OBX.5.1
-        I L=1 D
-        .S TERM="TOTAL PATIENTS EVALUATED"
-        .S OV(1)=$G(^TMP("PXRM7",$J,810.33,IENX,2,"E"))_"~"_TERM
-        .S $P(OV,"^",1)=OV(1)
-        ;---------------------------------------------------
-        ;15 TOTAL PATIENTS APPLICABLE - REMINDER     OBX.5.2
-        I L=1 D
-        .S TERM="TOTAL PATIENTS APPLICABLE"
-        .S OV(2)=$G(^TMP("PXRM7",$J,810.33,IENX,3,"E"))_"~"_TERM
-        .S $P(OV,"^",2)=OV(2)
-        ;---------------------------------------------------
-        ;16 TOTAL PATIENTS NOT APPLICABLE - REMINDER OBX.5.3
-        I L=1 D
-        .S TERM="TOTAL PATIENTS NOT APPLICABLE"
-        .S OV(3)=$G(^TMP("PXRM7",$J,810.33,IENX,4,"E"))_"~"_TERM
-        .S $P(OV,"^",3)=OV(3)
-        ;---------------------------------------------------
-        ;17 TOTAL PATIENTS DUE - REMINDER            OBX.5.4
-        I L=1 D
-        .S TERM="TOTAL PATIENTS DUE"
-        .S OV(4)=$G(^TMP("PXRM7",$J,810.33,IENX,5,"E"))_"~"_TERM
-        .S $P(OV,"^",4)=OV(4)
-        ;---------------------------------------------------
-        ;18 TOTAL PATIENTS NOT DUE - REMINDER        OBX.5.5
-        I L=1 D
-        .S TERM="TOTAL PATIENTS NOT DUE"
-        .S OV(5)=$G(^TMP("PXRM7",$J,810.33,IENX,6,"E"))_"~"_TERM
-        .S $P(OV,"^",5)=OV(5)
-        ;---------------------------------------------------
-        ;23 TOTAL COUNT - FINDING                    OBX.5.1
-        I L=2 D
-        .S TERM="TOTAL COUNT"
-        .S OV(1)=$G(^TMP("PXRM7",$J,810.331,IENZ,1,"E"))_"~"_TERM
-        .S $P(OV,"^",1)=OV(1)
-        ;---------------------------------------------------
-        ;24 APPLICABLE COUNT - FINDING               OBX.5.2
-        I L=2 D
-        .S TERM="APPLICABLE COUNT"
-        .S OV(2)=$G(^TMP("PXRM7",$J,810.331,IENZ,2,"E"))_"~"_TERM
-        .S $P(OV,"^",2)=OV(2)
-        ;---------------------------------------------------
-        ;25 NOT APPLICABLE COUNT- FINDING            OBX.5.3
-        I L=2 D
-        .S TERM="NOT APPLICABLE COUNT"
-        .S OV(3)=$G(^TMP("PXRM7",$J,810.331,IENZ,3,"E"))_"~"_TERM
-        .S $P(OV,"^",3)=OV(3)
-        ;---------------------------------------------------
-        ;26 DUE COUNT - FINDING                      OBX.5.4
-        I L=2 D
-        .S TERM="DUE COUNT"
-        .S OV(4)=$G(^TMP("PXRM7",$J,810.331,IENZ,4,"E"))_"~"_TERM
-        .S $P(OV,"^",4)=OV(4)
-        ;---------------------------------------------------
-        ;27 NOT DUE COUNT - FINDING                  OBX.5.5
-        I L=2 D
-        .S TERM="NOT DUE COUNT"
-        .S OV(5)=$G(^TMP("PXRM7",$J,810.331,IENZ,5,"E"))_"~"_TERM
-        .S $P(OV,"^",5)=OV(5)
-        ;---------------------------------------------------
-        ;FINISH POPULATING OBX SEGMENT
-        S $P(OBX(+SEQ_L),"|",6)=OV
-        K OV
-        ;---------------------------------------------------
-        ;###---Set message in HL7 array
-        S ^TMP("HLS",$J,LINE)=$G(OBX(+SEQ_L)),LINE=LINE+1
-        ;
-        I SEE=1 W !,"   ",OBX(+SEQ_L)
-        K OBX
-        ;---------------------------------------------------
-        Q
+PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 03/21/2002 ;4/11/02  15:26
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;This is the beginning of the extraction from the extract file
+ ;
+ ;VARIABLE LIST
+ ;IEN = IEN OF ENTRY IN EXTRACT FILE 810.3
+ Q
+SPLIT ;SPLIT MESSAGES
+ N ORC2
+ I LINE>100 D
+ .S ORCCNT=ORCCNT+1
+ .D EN^PXRM7M1(.ID)
+ .K ^TMP("HLS",$J)
+ .S ORC2=$G(^TMP("PXRM7HLORC",$J))
+ .S $P(ORC2,"|",3)="P"_ORCCNT,ORC=ORC2
+ .S LINE=2
+ .I $D(SEE) W !,ORC
+ .S ^TMP("HLS",$J,1)=ORC
+ Q
+ ;
+EXTRACT(IEN,SEE,ID,MODE) ;
+ N ORCCNT
+ K ERROR,LINE
+ S ORCCNT=1  ;Count of ORC segments or number of messages created
+ S LINE=1 ;Line count for the ^TMP("HL7",$J,LINE) global variable
+ ;-Verify Values
+ I '$D(^PXRMXT(810.3,IEN)) S ERROR(1)="No Such IEN in file 810.3 "_IEN
+ I $D(ERROR) D  Q
+ .I $D(SEE)=1
+ ;-Extracting Value of Nodes in file
+ I $D(ERROR) Q
+ D GETS^DIQ(810.3,IEN,"**","EI","^TMP(""PXRM7"",$J)")
+ D ORCSEG
+ ;******Add NTE segment to end of message *******
+ ;******change 3rd piece of ORC segement to L (last)****
+ S NTE="NTE||"_LAST_"||"
+ S ^TMP("HLS",$J,LINE)=NTE,LINE=LINE+1
+ I SEE=1 W !,NTE
+ K NTE,LAST
+ S ORC=$G(^TMP("HLS",$J,1)),$P(ORC,"|",3)="F"_ORCCNT,^TMP("HLS",$J,1)=ORC
+ ;***********************************************
+ ;*******TURN ON BELOW TO TRANSMIT TO AUSTIN *****
+ D EN^PXRM7M1(.ID)
+ ;***********************************************
+ K ^TMP("PXRM7",$J)
+ K ^TMP("HLS",$J)
+ K ^TMP("PXRM7HLORC",$J)
+ ;********KILL LEFT OVER ARRAYS AND VARIABLES*****
+ K HL("EID"),HLA("HLS"),PROTIEN,PXRM7,PXRM77,PXRM7ID,PXRM7R,ZMID
+ K DA,DISYS,DISYS,EO,HL("EIDS"),HLECH,HLFS,HLN,HLQ,HLSAN,HLX
+ K IENIEN,IENOBR,IENX,IENY,IENZ,L,LINE,NEXT,QTI,RFS,SEQ
+ K STATION,USI
+ ;**************************************************
+ Q
+ORCSEG ;CREATE ORC SEGMENTS
+ ;ORDERED IN ORDER OF APPEARANCE IN SEGMENT
+ ;QTI=QUANTITY AND TIMING
+ ;EO=ENTERING ORGANIZATION
+ ;--Below adds extra line feed in front of the message. --
+ ;---------------------------------------------------
+ S IENY=IEN_","
+ ;---------------------------------------------
+ ;0 PLACER ORDER NUMBER      ORC.2.1
+ S $P(ORC,"|",3)="P1"
+ ;---------------------------------------------
+ ;1 REPORTING PERIOD         ORC.7.1.1
+ S QTI(1)=$G(^TMP("PXRM7",$J,810.3,IENY,3,"E"))
+ S $P(QTI,"~",1)=QTI(1)
+ ;---------------------------------------------
+ ;2 QUARTER                  ORC.7.3
+ S QTI(3)=$G(^TMP("PXRM7",$J,810.3,IENY,7,"E"))
+ S $P(QTI,"~",3)=QTI(3)
+ ;---------------------------------------------
+ ;3 BEGINNING DATE           ORC.7.4.1
+ S QTI(4)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.02,"I")),"DT")
+ S $P(QTI,"~",4)=QTI(4)
+ ;---------------------------------------------
+ ;4 ENDING DATE              ORC.7.5.1
+ S QTI(5)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.03,"I")),"DT")
+ S $P(QTI,"~",5)=QTI(5)
+ ;---------------------------------------------
+ ;5 REPORTING YEAR           ORC.7.11.2
+ S QTI(11)="&"_$G(^TMP("PXRM7",$J,810.3,IENY,4,"E"))
+ S $P(QTI,"~",11)=QTI(11)
+ ;---------------------------------------------
+ ;6 EXTRACT DATE             ORC.9.1
+ S $P(ORC,"|",10)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.06,"I")),"DT")
+ ;---------------------------------------------
+ ;7 NAME                     ORC.17.2
+ S EO(2)=$G(^TMP("PXRM7",$J,810.3,IENY,.01,"E"))
+ S $P(EO,"~",2)=EO(2)
+ ;---------------------------------------------
+ ;8 REPORT EXTRACT PARAMETER ORC.17.5
+ S EO(5)=$G(^TMP("PXRM7",$J,810.3,IENY,1,"E"))
+ S $P(EO,"~",5)=EO(5)
+ ;---------------------------------------------
+ ;9 REPORT EXTRACT TYPE      ORC.18.2
+ S $P(ORC,"|",19)="~"_$G(^TMP("PXRM7",$J,810.3,IENY,2,"E"))
+ ;---------------------------------------------
+ ;FINISH POPULATING ORC SEGMENT
+ S $P(ORC,"|",8)=QTI
+ S $P(ORC,"|",18)=EO
+ S $P(ORC,"|",1)="ORC"
+ ;---------------------------------------------
+ ;SET HL7 TMP ARRAY AND SHOW SEGMENT
+ S ^TMP("HLS",$J,LINE)=ORC,LINE=LINE+1
+ I SEE=1 W !,ORC
+ S ^TMP("PXRM7HLORC",$J)=ORC
+ K ORC
+OBRSEG ;CREATE OBR SEGMENTS
+ ;N IENOBR,SEQ,USI,QTI,NEXT,STATION
+ ;USI=UNIVERSAL SERVICE ID
+ ;RFS=REASON FOR STUDY
+ ;
+ S NEXT=1,LAST=0
+ S IENOBR=0 F  S IENOBR=$O(^PXRMXT(810.3,IEN,3,IENOBR)) Q:IENOBR<1  D
+ .S IENIEN=-1 F  S IENIEN=$O(^PXRMXT(810.3,IEN,3,IENOBR,1,IENIEN)) Q:IENIEN="B"  D  Q:IENIEN=""
+ ..S L=$S(IENIEN=0:1,IENIEN>0:2,IENIEN="":1,1:"")
+ ..;###---Set Sequence Number
+ ..S IENX=IENOBR_","_IEN_","
+ ..S IENZ=IENIEN_","_IENOBR_","_IEN_","
+ ..S SEQ=$G(^TMP("PXRM7",$J,810.33,IENX,.01,"E"))
+ ..S OBR(+SEQ_L)="OBR|1|||||||||||||||||||||||||||||||"
+ ..S $P(OBR(+SEQ_L),"|",2)=NEXT,LAST=NEXT,NEXT=NEXT+1
+ ..;--------------------------------------------------
+ ..;10 COUNT TYPE           OBR.4.2
+ ..;R=REMINDER COUNTS  F=FINDING COUNTS
+ ..S USI(2)=$S(L=1:"R",L=2:"F",1:"")
+ ..S $P(USI,"~",2)=USI(2)
+ ..;--------------------------------------------------
+ ..;11 REMINDER             OBR.4.5
+ ..S USI(5)=$G(^TMP("PXRM7",$J,810.33,IENX,.02,"E"))
+ ..S $P(USI,"~",5)=USI(5)
+ ..;--------------------------------------------------
+ ..;12 STATION              OBR.3.1
+ ..S STATION=$G(^TMP("PXRM7",$J,810.33,IENX,.03,"I"))_","
+ ..D GETS^DIQ(4,STATION,"**","E","^TMP(""PXRM7"",$J)")
+ ..S $P(OBR(+SEQ_L),"|",4)=$G(^TMP("PXRM7",$J,4,STATION,99,"E"))
+ ..;--------------------------------------------------
+ ..;13 PATIENT LIST         OBR.31.2
+ ..S RFS(2)=$G(^TMP("PXRM7",$J,810.33,IENX,.04,"E"))
+ ..S $P(RFS,"~",2)=RFS(2)
+ ..;--------------------------------------------------
+ ..;19 REMINDER TERM        OBR.31.1
+ ..S RFS(1)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.02,"E")),1:"")
+ ..S $P(RFS,"~",1)=RFS(1)
+ ..;--------------------------------------------------
+ ..;20 FINDING TOTAL TYPE   OBR.31.4
+ ..S RFS(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.03,"E")),1:"")
+ ..S $P(RFS,"~",4)=RFS(4)
+ ..;--------------------------------------------------
+ ..;21 GROUP NAME           OBR.31.5
+ ..S RFS(5)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.04,"E")),1:"")
+ ..S $P(RFS,"~",5)=RFS(5)
+ ..;--------------------------------------------------
+ ..;22 REMINDER STATUS      OBR.4.4
+ ..S USI(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.05,"I")),1:"")
+ ..S $P(USI,"~",4)=USI(4)
+ ..;-------------------------------------------------
+ ..;FINISH POPULATING OBR SEGMENT
+ ..S $P(OBR(+SEQ_L),"|",5)=USI
+ ..S $P(OBR(+SEQ_L),"|",32)=RFS
+ ..;-------------------------------------------------
+ ..;---Set message in HL7 array
+ ..;I $L($G(OBR(+SEQ_L)))=255 S OBR(+SEQ_L)=OBR(+SEQ_L)_"|||" 
+ ..S ^TMP("HLS",$J,LINE)=$G(OBR(+SEQ_L)),LINE=LINE+1
+ ..;
+ ..I SEE=1 W !," ",OBR(+SEQ_L)
+ ..K OBR
+ ..D OBXSEG
+ ..D SPLIT
+ ..I (L=1)&(IENIEN="") Q
+ Q
+OBXSEG ;CREATE THE OBX SEGMENTS
+ N TERM
+ ;OV=OBSERVATION VALUE
+ S $P(OBX(+SEQ_L),"|",3)="MO"
+ S $P(OBX(+SEQ_L),"|",1)="OBX"
+ ;---------------------------------------------------
+ ;###---SET SEQUENCE NUMBER
+ S $P(OBX(+SEQ_L),"|",2)=1
+ ;---------------------------------------------------
+ ;14 TOTAL PATIENTS EVALUATED - REMINDER      OBX.5.1
+ I L=1 D
+ .S TERM="TOTAL PATIENTS EVALUATED"
+ .S OV(1)=$G(^TMP("PXRM7",$J,810.33,IENX,2,"E"))_"~"_TERM
+ .S $P(OV,"^",1)=OV(1)
+ ;---------------------------------------------------
+ ;15 TOTAL PATIENTS APPLICABLE - REMINDER     OBX.5.2
+ I L=1 D
+ .S TERM="TOTAL PATIENTS APPLICABLE"
+ .S OV(2)=$G(^TMP("PXRM7",$J,810.33,IENX,3,"E"))_"~"_TERM
+ .S $P(OV,"^",2)=OV(2)
+ ;---------------------------------------------------
+ ;16 TOTAL PATIENTS NOT APPLICABLE - REMINDER OBX.5.3
+ I L=1 D
+ .S TERM="TOTAL PATIENTS NOT APPLICABLE"
+ .S OV(3)=$G(^TMP("PXRM7",$J,810.33,IENX,4,"E"))_"~"_TERM
+ .S $P(OV,"^",3)=OV(3)
+ ;---------------------------------------------------
+ ;17 TOTAL PATIENTS DUE - REMINDER            OBX.5.4
+ I L=1 D
+ .S TERM="TOTAL PATIENTS DUE"
+ .S OV(4)=$G(^TMP("PXRM7",$J,810.33,IENX,5,"E"))_"~"_TERM
+ .S $P(OV,"^",4)=OV(4)
+ ;---------------------------------------------------
+ ;18 TOTAL PATIENTS NOT DUE - REMINDER        OBX.5.5
+ I L=1 D
+ .S TERM="TOTAL PATIENTS NOT DUE"
+ .S OV(5)=$G(^TMP("PXRM7",$J,810.33,IENX,6,"E"))_"~"_TERM
+ .S $P(OV,"^",5)=OV(5)
+ ;---------------------------------------------------
+ ;23 TOTAL COUNT - FINDING                    OBX.5.1
+ I L=2 D
+ .S TERM="TOTAL COUNT"
+ .S OV(1)=$G(^TMP("PXRM7",$J,810.331,IENZ,1,"E"))_"~"_TERM
+ .S $P(OV,"^",1)=OV(1)
+ ;---------------------------------------------------
+ ;24 APPLICABLE COUNT - FINDING               OBX.5.2
+ I L=2 D
+ .S TERM="APPLICABLE COUNT"
+ .S OV(2)=$G(^TMP("PXRM7",$J,810.331,IENZ,2,"E"))_"~"_TERM
+ .S $P(OV,"^",2)=OV(2)
+ ;---------------------------------------------------
+ ;25 NOT APPLICABLE COUNT- FINDING            OBX.5.3
+ I L=2 D
+ .S TERM="NOT APPLICABLE COUNT"
+ .S OV(3)=$G(^TMP("PXRM7",$J,810.331,IENZ,3,"E"))_"~"_TERM
+ .S $P(OV,"^",3)=OV(3)
+ ;---------------------------------------------------
+ ;26 DUE COUNT - FINDING                      OBX.5.4
+ I L=2 D
+ .S TERM="DUE COUNT"
+ .S OV(4)=$G(^TMP("PXRM7",$J,810.331,IENZ,4,"E"))_"~"_TERM
+ .S $P(OV,"^",4)=OV(4)
+ ;---------------------------------------------------
+ ;27 NOT DUE COUNT - FINDING                  OBX.5.5
+ I L=2 D
+ .S TERM="NOT DUE COUNT"
+ .S OV(5)=$G(^TMP("PXRM7",$J,810.331,IENZ,5,"E"))_"~"_TERM
+ .S $P(OV,"^",5)=OV(5)
+ ;---------------------------------------------------
+ ;FINISH POPULATING OBX SEGMENT
+ S $P(OBX(+SEQ_L),"|",6)=OV
+ K OV
+ ;---------------------------------------------------
+ ;###---Set message in HL7 array
+ S ^TMP("HLS",$J,LINE)=$G(OBX(+SEQ_L)),LINE=LINE+1
+ ;
+ I SEE=1 W !,"   ",OBX(+SEQ_L)
+ K OBX
+ ;---------------------------------------------------
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m

@@ -1 @@
-PXRMCDUE        ;SLC/PKR - Custom date due calculation routines. ;09/05/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;========================================================
-CDBUILD(STRING,DA)      ;Given a custom date due string build the data
-        ;structure. This is called by a new-style cross-reference after
-        ;the date due string has passed the input transform so we don't need
-        ;to validate the elements.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        N FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG,NARGS,PFSTACK
-        S STRING=$$UP^XLFSTR(STRING)
-        D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
-        S IENS=DA_","
-        S FDA(811.9,IENS,46)=FUNCTION,FDA(811.9,IENS,47)=NARGS
-        S IENB=DA
-        F IND=1:1:NARGS D
-        . S IENB=IENB+1
-        . S IENS="+"_IENB_","_DA_","
-        . S FDA(811.948,IENS,.01)=FILIST(IND)
-        . S FDA(811.948,IENS,.02)=FREQLIST(IND)
-        D UPDATE^DIE("","FDA","","MSG")
-        I $D(MSG) D
-        . W !,"The update failed, UPDATE^DIE returned the following error message:"
-        . D AWRITE^PXRMUTIL("MSG")
-        Q
-        ;
-        ;========================================================
-CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return
-        ;the due date.
-        N DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,NARGS,TEMP
-        S FUNCTION=$P(DEFARR(46),U,1)
-        S NARGS=$P(DEFARR(46),U,2)
-        F IND=1:1:NARGS D
-        . S TEMP=DEFARR(47,IND,0)
-        . S FI=$P(TEMP,U,1)
-        . S FREQ=$P(TEMP,U,2)
-        . S DATE=$S(FIEVAL(FI):+FIEVAL(FI,"DATE"),1:0)
-        . I DATE>0 S DATE=$$FULLDATE^PXRMDATE(DATE)
-        . S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ)
-        S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),1:0)
-        S DDUE=$P(TEMP,U,1)
-        I DDUE=0 Q -1
-        S IND=$P(TEMP,U,2)
-        S TEMP=DEFARR(47,IND,0)
-        S FI=$P(TEMP,U,1)
-        S FREQ=$P(TEMP,U,2)
-        S DATE=+$G(FIEVAL(FI,"DATE"))
-        S ^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")=FI_U_FREQ_U_DATE
-        Q DDUE
-        ;
-        ;========================================================
-CDKILL(X,DA)    ;
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        K ^PXD(811.9,DA,46),^PXD(811.9,DA,47)
-        Q
-        ;
-        ;========================================================
-MAXDATE(NARGS,DLIST)    ;Return the maximum date from a list of dates in DLIST.
-        N IND,INDS,MAXDATE
-        S (INDS,MAXDATE)=0
-        F IND=1:1:NARGS I DLIST(IND)>MAXDATE S MAXDATE=DLIST(IND),INDS=IND
-        Q MAXDATE_U_INDS
-        ;
-        ;========================================================
-MINDATE(NARGS,DLIST)    ;Return the minimum date from a list of dates in DLIST.
-        ;Only return 0 if there is no "real" date in the list.
-        N DATE,IND,INDS,MINDATE
-        S INDS=0
-        S MINDATE=9991231
-        F IND=1:1:NARGS S DATE=DLIST(IND) I DATE<MINDATE,DATE'=0 S MINDATE=DATE,INDS=IND
-        I MINDATE=9991231 S MINDATE=0
-        Q MINDATE_U_INDS
-        ;
-        ;========================================================
-OUTPUT(CDUEDATA,DEFARR) ;Build the custom date due output text.
-        N CDUEFI,ENTRY,FINAME,TEXT,VPTR
-        S CDUEFI=$P(CDUEDATA,U,1)
-        S VPTR=$P(^PXD(811.9,DEFARR("IEN"),20,CDUEFI,0),U,1)
-        S ENTRY="^"_$P(VPTR,";",2)_$P(VPTR,";",1)_",0)"
-        S FINAME=$P(@ENTRY,U,1)
-        S TEXT="Custom date due based on date of finding "_CDUEFI_" ("_FINAME_")"
-        S TEXT=TEXT_" plus frequency of "_$P(CDUEDATA,U,2)_"."
-        Q TEXT
-        ;
-        ;========================================================
-PARSE(STRING,FUNCTION,NARGS,FILIST,FREQLIST)    ;Parse a custom date due
-        ;string and return the function, number of arguments, finding list,
-        ;and frequency list. An argument has the form M+NF where M is a
-        ;finding number, N is an integer, and F is D, M, or Y.
-        N IND,OPER,PFSTACK
-        S OPER=","
-        D POSTFIX^PXRMSTAC(STRING,OPER,.PFSTACK)
-        S FUNCTION=$$UP^XLFSTR(PFSTACK(1))
-        S NARGS=0
-        F IND=2:1:PFSTACK(0) D
-        . I PFSTACK(IND)=OPER Q
-        . S NARGS=NARGS+1
-        . S FILIST(NARGS)=$P(PFSTACK(IND),"+",1)
-        . S FREQLIST(NARGS)=$P(PFSTACK(IND),"+",2)
-        Q
-        ;
-        ;========================================================
-VFREQ(FREQ)     ;Make sure FREQ is a valid frequency.
-        N VALID
-        S VALID=1
-        S FREQ=$$UP^XLFSTR(FREQ)
-        I (FREQ'?1N.N1"D"),(FREQ'?1N.N1"M"),(FREQ'?1N.N1"Y") S VALID=0
-        Q VALID
-        ;
-        ;========================================================
-VCDUE(STRING,DA)        ;Make sure a custom date due string is valid.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q 1
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q 1
-        I '$D(DA) Q 1
-        I $L(STRING)>245 Q 0
-        N FILIST,FREQLIST,FUNCTION,IND,NARGS,TEXT,VALID
-        D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
-        S VALID=1
-        I FUNCTION'="MIN_DATE",FUNCTION'="MAX_DATE" D
-        . S TEXT=FUNCTION_" is not a valid custom date due function"
-        . D EN^DDIOL(TEXT)
-        . S VALID=0
-        F IND=1:1:NARGS D
-        . I '$D(^PXD(811.9,DA,20,FILIST(IND),0)) D
-        .. S TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding"
-        .. D EN^DDIOL(TEXT)
-        .. S VALID=0
-        . I '$$VFREQ(FREQLIST(IND)) D
-        .. S TEXT=FREQLIST(IND)_" is not a valid frequency"
-        .. D EN^DDIOL(TEXT)
-        .. S VALID=0
-        Q VALID
-        ;
-        ;========================================================
-XHELP   ;Executable help for custom date due.
-        N DONE,IND,TEXT
-        S DONE=0
-        F IND=1:1 Q:DONE  D
-        . S TEXT=$P($T(TEXT+IND),";",3)
-        . I TEXT="**End Text**" S DONE=1 Q
-        . W !,TEXT
-        Q
-        ;
-        ;========================================================
-TEXT    ;Custom Date Due help text.
-        ;;The general form for a Custom Date Due string is:
-        ;; FUNCTION(ARG1,ARG2,...,ARGN)
-        ;;where FUNCTION is MAX_DATE or MIN_DATE and the arguments have the form
-        ;;M+FREQ where M is a finding number and FREQ is a number followed by
-        ;;D for days, M for months, or Y for years.
-        ;;Here is an example:
-        ;; MAX_DATE(1+6M,3+1Y)
-        ;;This will take the date of finding 1 and add 6 months, the date of finding 3
-        ;;and add 1 year and set the date due to the maximum of those two dates.
-        ;;
-        ;;**End Text**
-        Q
-        ;
+PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;06/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;========================================================
+CDBUILD(STRING,DA) ;Given a custom date due string build the data
+ ;structure. This is called by a new-style cross-reference after
+ ;the date due string has passed the input transform so we don't need
+ ;to validate the elements.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ N FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG,NARGS,PFSTACK
+ S STRING=$$UP^XLFSTR(STRING)
+ D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
+ S IENS=DA_","
+ S FDA(811.9,IENS,46)=FUNCTION,FDA(811.9,IENS,47)=NARGS
+ S IENB=DA
+ F IND=1:1:NARGS D
+ . S IENB=IENB+1
+ . S IENS="+"_IENB_","_DA_","
+ . S FDA(811.948,IENS,.01)=FILIST(IND)
+ . S FDA(811.948,IENS,.02)=FREQLIST(IND)
+ D UPDATE^DIE("","FDA","","MSG")
+ I $D(MSG) D
+ . W !,"The update failed, UPDATE^DIE returned the following error message:"
+ . D AWRITE^PXRMUTIL("MSG")
+ Q
+ ;
+ ;========================================================
+CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return
+ ;the due date.
+ N DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,NARGS,TEMP
+ S FUNCTION=$P(DEFARR(46),U,1)
+ S NARGS=$P(DEFARR(46),U,2)
+ F IND=1:1:NARGS D
+ . S TEMP=DEFARR(47,IND,0)
+ . S FI=$P(TEMP,U,1)
+ . S FREQ=$P(TEMP,U,2)
+ . S DATE=+$G(FIEVAL(FI,"DATE"))
+ . S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ)
+ S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST))
+ S DDUE=$P(TEMP,U,1)
+ I DDUE=0 Q -1
+ S IND=$P(TEMP,U,2)
+ S TEMP=DEFARR(47,IND,0)
+ S FI=$P(TEMP,U,1)
+ S FREQ=$P(TEMP,U,2)
+ S DATE=+$G(FIEVAL(FI,"DATE"))
+ S ^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")=FI_U_FREQ_U_DATE
+ Q DDUE
+ ;
+ ;========================================================
+CDKILL(X,DA) ;
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ K ^PXD(811.9,DA,46),^PXD(811.9,DA,47)
+ Q
+ ;
+ ;========================================================
+MAXDATE(NARGS,DLIST) ;Return the maximum date from a list of dates in DLIST.
+ N IND,INDS,MAXDATE
+ S (INDS,MAXDATE)=0
+ F IND=1:1:NARGS I DLIST(IND)>MAXDATE S MAXDATE=DLIST(IND),INDS=IND
+ Q MAXDATE_U_INDS
+ ;
+ ;========================================================
+MINDATE(NARGS,DLIST) ;Return the minimum date from a list of dates in DLIST.
+ ;Only return 0 if there is no "real" date in the list.
+ N DATE,IND,INDS,MINDATE
+ S INDS=0
+ S MINDATE=9991231
+ F IND=1:1:NARGS S DATE=DLIST(IND) I DATE<MINDATE,DATE'=0 S MINDATE=DATE,INDS=IND
+ I MINDATE=9991231 S MINDATE=0
+ Q MINDATE_U_INDS
+ ;
+ ;========================================================
+OUTPUT(CDUEDATA,DEFARR) ;Build the custom date due output text.
+ N CDUEFI,ENTRY,FINAME,TEXT,VPTR
+ S CDUEFI=$P(CDUEDATA,U,1)
+ S VPTR=$P(^PXD(811.9,DEFARR("IEN"),20,CDUEFI,0),U,1)
+ S ENTRY="^"_$P(VPTR,";",2)_$P(VPTR,";",1)_",0)"
+ S FINAME=$P(@ENTRY,U,1)
+ S TEXT="Custom date due based on date of finding "_CDUEFI_" ("_FINAME_")"
+ S TEXT=TEXT_" plus frequency of "_$P(CDUEDATA,U,2)_"."
+ Q TEXT
+ ;
+ ;========================================================
+PARSE(STRING,FUNCTION,NARGS,FILIST,FREQLIST) ;Parse a custom date due
+ ;string and return the function, number of arguments, finding list,
+ ;and frequency list. An argument has the form M+NF where M is a
+ ;finding number, N is an integer, and F is D, M, or Y.
+ N IND,OPER,PFSTACK
+ S OPER=","
+ D POSTFIX^PXRMSTAC(STRING,OPER,.PFSTACK)
+ S FUNCTION=$$UP^XLFSTR(PFSTACK(1))
+ S NARGS=0
+ F IND=2:1:PFSTACK(0) D
+ . I PFSTACK(IND)=OPER Q
+ . S NARGS=NARGS+1
+ . S FILIST(NARGS)=$P(PFSTACK(IND),"+",1)
+ . S FREQLIST(NARGS)=$P(PFSTACK(IND),"+",2)
+ Q
+ ;
+ ;========================================================
+VFREQ(FREQ) ;Make sure FREQ is a valid frequency.
+ N VALID
+ S VALID=1
+ S FREQ=$$UP^XLFSTR(FREQ)
+ I (FREQ'?1N.N1"D"),(FREQ'?1N.N1"M"),(FREQ'?1N.N1"Y") S VALID=0
+ Q VALID
+ ;
+ ;========================================================
+VCDUE(STRING,DA) ;Make sure a custom date due string is valid.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q 1
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q 1
+ I '$D(DA) Q 1
+ I $L(STRING)>245 Q 0
+ N FILIST,FREQLIST,FUNCTION,IND,NARGS,TEXT,VALID
+ D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST)
+ S VALID=1
+ I FUNCTION'="MIN_DATE",FUNCTION'="MAX_DATE" D
+ . S TEXT=FUNCTION_" is not a valid custom date due function"
+ . D EN^DDIOL(TEXT)
+ . S VALID=0
+ F IND=1:1:NARGS D
+ . I '$D(^PXD(811.9,DA,20,FILIST(IND),0)) D
+ .. S TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding"
+ .. D EN^DDIOL(TEXT)
+ .. S VALID=0
+ . I '$$VFREQ(FREQLIST(IND)) D
+ .. S TEXT=FREQLIST(IND)_" is not a valid frequency"
+ .. D EN^DDIOL(TEXT)
+ .. S VALID=0
+ Q VALID
+ ;
+ ;========================================================
+XHELP ;Executable help for custom date due.
+ N DONE,IND,TEXT
+ S DONE=0
+ F IND=1:1 Q:DONE  D
+ . S TEXT=$P($T(TEXT+IND),";",3)
+ . I TEXT="**End Text**" S DONE=1 Q
+ . W !,TEXT
+ Q
+ ;
+ ;========================================================
+TEXT ;Custom Date Due help text.
+ ;;The general form for a Custom Date Due string is:
+ ;; FUNCTION(ARG1,ARG2,...,ARGN)
+ ;;where FUNCTION is MAX_DATE or MIN_DATE and the arguments have the form
+ ;;M+FREQ where M is a finding number and FREQ is a number followed by
+ ;;D for days, M for months, or Y for years.
+ ;;Here is an example:
+ ;; MAX_DATE(1+6M,3+1Y)
+ ;;This will take the date of finding 1 and add 6 months, the date of finding 3
+ ;;and add 1 year and set the date due to the maximum of those two dates.
+ ;;
+ ;;**End Text**
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m

@@ -1 @@
-PXRMCF  ; SLC/PKR - Handle computed findings. ;07/25/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=======================================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate computed findings.
-        N FIEVT,FILENUM,FINDING,FINDPA,ITEM
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        S ITEM=""
-        F  S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0  D
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0  D
-        .. K FINDPA
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. K FIEVT
-        .. D FIEVAL(FILENUM,DFN,ITEM,.FINDPA,.FIEVT)
-        .. M FIEVAL(FINDING)=FIEVT
-        .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
-        Q
-        ;
-        ;=======================================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;Patient list evaluator.
-        ;Return the list in ^TMP($J,PLIST)
-        N ITEM,FILENUM,PFINDPA
-        N TEMP,TFINDING,TFINDPA
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        S ITEM=""
-        F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
-        .. K PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D GPLIST(FILENUM,ITEM,.PFINDPA,PLIST)
-        Q
-        ;
-        ;=======================================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;General term
-        ;evaluator.
-        N FIEVT,FILENUM,ITEM,PFINDPA
-        N TEMP,TFINDING,TFINDPA
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        S ITEM=""
-        F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
-        .. K FIEVT,PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D FIEVAL(FILENUM,DFN,ITEM,.PFINDPA,.FIEVT)
-        .. M TFIEVAL(TFINDING)=FIEVT
-        .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
-        Q
-        ;
-        ;=======================================================
-FIEVAL(FILENUM,DFN,ITEM,PFINDPA,FIEVAL) ;
-        ;Evaluate regular patient findings.
-        N BDT,CASESEN,COND,CONVAL,DAS,DATA,DATE,EDT,FLIST,ICOND,IND
-        N NFOUND,NGET,NOCC,NP,PDATA,ROUTINE
-        N SAVE,SDIR,STATUSA,TEMP,TEST,TEXT,TYPE,UCIFS,VALUE,VSLIST
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
-        S SDIR=$S(NOCC<0:+1,1:-1)
-        S TEST=PFINDPA(15)
-        D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
-        ;Make sure NGET has the same sign as NOCC.
-        I NGET'=NOCC S NGET=NGET*($$ABS^XLFMTH(NOCC)/NOCC)
-        S TEMP=^PXRMD(811.4,ITEM,0)
-        S TYPE=$P(TEMP,U,5)
-        I TYPE="" S TYPE="S"
-        I TYPE="S" D
-        . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,.TEST,.DATE,.VALUE,.TEXT)"
-        . D @ROUTINE
-        .;Make sure that the date is in range.
-        . I TEST,DATE'<BDT,DATE'>EDT S NFOUND=1
-        . E  S NFOUND=0
-        . I NFOUND D
-        .. S TEST(1)=TEST,DATE(1)=DATE,TEXT(1)=$G(TEXT)
-        .. S DATA(1,"VALUE")=$G(VALUE)
-        .. I $D(VALUE)=11 S IND="" F  S IND=$O(VALUE(IND)) Q:IND=""  S DATA(1,IND)=VALUE(IND)
-        I TYPE="M" D
-        . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)"
-        . D @ROUTINE
-        I TYPE'="S",TYPE'="M" D
-        . S NFOUND=0
-        . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","COMPUTED FINDING","WRONG TYPE")=TYPE_" IS NOT SUITABLE FOR REMINDER EVALUATION"
-        I NFOUND=0 S FIEVAL=0 Q
-        S NP=0
-        F IND=1:1:NFOUND Q:NP=NOCC  D
-        . I TEST(IND),COND'="" D
-        .. K PDATA M PDATA=DATA(IND)
-        .. S CONVAL=$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.PDATA)
-        . E  S CONVAL=TEST(IND)
-        . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        . I SAVE D
-        .. S NP=NP+1
-        .. S FIEVAL(NP)=CONVAL
-        .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
-        .. S FIEVAL(NP,"DATE")=DATE(IND)
-        .. S FIEVAL(NP,"TEXT")=$G(TEXT(IND))
-        .. M FIEVAL(NP)=DATA(IND)
-        .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=DATA(IND)
-        ;
-        ;Save the finding result.
-        D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
-        S FIEVAL("FILE NUMBER")=FILENUM
-        Q
-        ;
-        ;=======================================================
-GPLIST(FILENUM,CFIEN,PFINDPA,PLIST)     ;Add to the patient list
-        ;for a regular file.
-        N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DATA,DFN,FLIST
-        N ICOND,IND,IPLIST
-        N NOCC,NOCCABS,NFOUND,NGET,NP,PARAM,ROUTINE
-        N SAVE,SOURCE,STATUSA,TEMP,TEXT,TGLIST,TPLIST,TYPE
-        N UCIFS,VALUE,VSLIST
-        S TEMP=^PXRMD(811.4,CFIEN,0)
-        S TYPE=$P(TEMP,U,5)
-        I TYPE'="L" Q
-        S TGLIST="GPLIST_PXRMCF"
-        S PARAM=PFINDPA(15)
-        S SOURCE=FILENUM_";"_CFIEN
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
-        S NOCCABS=$$ABS^XLFMTH(NOCC)
-        D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCCABS)
-        K ^TMP($J,TGLIST)
-        S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(NGET,BDT,EDT,TGLIST,PARAM)"
-        D @ROUTINE
-        ;Routine should return:
-        ;^TMP($J,TGLIST,DFN,N)=DAS_U_DATE_U_FILENUM_U_ITEM_U_VALUE
-        ;Data values for condition are returned in
-        ;^TMP($J,TGLIST,DFN,N,SUB)=DATA(SUB)
-        S DFN=""
-        F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
-        . K TPLIST
-        . M TPLIST=^TMP($J,TGLIST,DFN)
-        . S (IND,NFOUND)=0
-        . K IPLIST
-        . F  S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCCABS)  D
-        .. S TEMP=TPLIST(IND)
-        .. K DATA M DATA=TPLIST(IND)
-        .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.DATA),1:1)
-        .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        .. I SAVE D
-        ... S NFOUND=NFOUND+1
-        ... S IPLIST(CONVAL,DFN,NFOUND,SOURCE)=TEMP
-        . M ^TMP($J,PLIST)=IPLIST
-        K ^TMP($J,TGLIST)
-        Q
-        ;
-        ;=======================================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        N DATA,DATE,FIEN,IND,JND,NAME,NOUT,PNAME,TEMP,TEXTOUT,VALUE
-        S FIEN=$P(IFIEVAL("FINDING"),";",1)
-        S TEMP=^PXRMD(811.4,FIEN,0)
-        S PNAME=$P(TEMP,U,4)
-        I PNAME="" S PNAME=$P(TEMP,U,1)
-        S NAME="Computed Finding: "_PNAME_" = "
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S VALUE=$G(IFIEVAL(IND,"VALUE"))
-        . S DATE=IFIEVAL(IND,"DATE")
-        . S TEMP=NAME_VALUE_" ("_$$EDATE^PXRMDATE(DATE)_")"
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;=======================================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        N DATA,DATE,FIEN,IND,JND,NOUT,PNAME,TEMP,TEXTOUT,VALUE
-        S FIEN=$P(IFIEVAL("FINDING"),";",1)
-        S TEMP=^PXRMD(811.4,FIEN,0)
-        S PNAME=$P(TEMP,U,4)
-        I PNAME="" S PNAME=$P(TEMP,U,1)
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Computed Finding: "_PNAME
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S DATE=IFIEVAL(IND,"DATE")
-        . S TEMP=$$EDATE^PXRMDATE(DATE)
-        . S VALUE=$G(IFIEVAL(IND,"VALUE"))
-        . I VALUE'="" S TEMP=TEMP_" value - "_VALUE
-        .;If there is text append it.
-        . I $G(IFIEVAL(IND,"TEXT"))'="" S TEMP=TEMP_"; "_IFIEVAL(IND,"TEXT")
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
+PXRMCF ; SLC/PKR - Handle computed findings. ;12/15/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=======================================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate computed findings.
+ N FIEVT,FILENUM,FINDING,FINDPA,ITEM
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ S ITEM=""
+ F  S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0  D
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0  D
+ .. K FINDPA
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. K FIEVT
+ .. D FIEVAL(FILENUM,DFN,ITEM,.FINDPA,.FIEVT)
+ .. M FIEVAL(FINDING)=FIEVT
+ .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
+ Q
+ ;
+ ;=======================================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Patient list evaluator.
+ ;Return the list in ^TMP($J,PLIST)
+ N ITEM,FILENUM,PFINDPA
+ N TEMP,TFINDING,TFINDPA
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ S ITEM=""
+ F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
+ .. K PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D GPLIST(FILENUM,ITEM,.PFINDPA,PLIST)
+ Q
+ ;
+ ;=======================================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term
+ ;evaluator.
+ N FIEVT,FILENUM,ITEM,PFINDPA
+ N TEMP,TFINDING,TFINDPA
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ S ITEM=""
+ F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
+ .. K FIEVT,PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D FIEVAL(FILENUM,DFN,ITEM,.PFINDPA,.FIEVT)
+ .. M TFIEVAL(TFINDING)=FIEVT
+ .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
+ Q
+ ;
+ ;=======================================================
+FIEVAL(FILENUM,DFN,ITEM,PFINDPA,FIEVAL) ;
+ ;Evaluate regular patient findings.
+ N BDT,CASESEN,COND,CONVAL,DAS,DATA,DATE,EDT,FLIST,ICOND,IND
+ N NFOUND,NGET,NOCC,NP,PDATA,ROUTINE
+ N SAVE,SDIR,STATUSA,TEMP,TEST,TEXT,TYPE,UCIFS,VALUE,VSLIST
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ S TEST=PFINDPA(15)
+ D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
+ S TEMP=^PXRMD(811.4,ITEM,0)
+ S TYPE=$P(TEMP,U,5)
+ I TYPE="" S TYPE="S"
+ I TYPE="S" D
+ . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,.TEST,.DATE,.VALUE,.TEXT)"
+ . D @ROUTINE
+ .;Make sure that the date is in range.
+ . I TEST,DATE'<BDT,DATE'>EDT S NFOUND=1
+ . E  S NFOUND=0
+ . I NFOUND D
+ .. S TEST(1)=TEST,DATE(1)=DATE,TEXT(1)=$G(TEXT)
+ .. S DATA(1,"VALUE")=$G(VALUE)
+ .. I $D(VALUE)=11 S IND="" F  S IND=$O(VALUE(IND)) Q:IND=""  S DATA(1,IND)=VALUE(IND)
+ I TYPE="M" D
+ . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)"
+ . D @ROUTINE
+ I TYPE'="S",TYPE'="M" D
+ . S NFOUND=0
+ . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","COMPUTED FINDING","WRONG TYPE")=TYPE_" IS NOT SUITABLE FOR REMINDER EVALUATION"
+ I NFOUND=0 S FIEVAL=0 Q
+ S NP=0
+ F IND=1:1:NFOUND Q:NP=NOCC  D
+ . I TEST(IND),COND'="" D
+ .. K PDATA M PDATA=DATA(IND)
+ .. S CONVAL=$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.PDATA)
+ . E  S CONVAL=TEST(IND)
+ . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ . I SAVE D
+ .. S NP=NP+1
+ .. S FIEVAL(NP)=CONVAL
+ .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
+ .. S FIEVAL(NP,"DATE")=DATE(IND)
+ .. S FIEVAL(NP,"TEXT")=$G(TEXT(IND))
+ .. M FIEVAL(NP)=DATA(IND)
+ .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=DATA(IND)
+ ;
+ ;Save the finding result.
+ D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
+ S FIEVAL("FILE NUMBER")=FILENUM
+ Q
+ ;
+ ;=======================================================
+GPLIST(FILENUM,CFIEN,PFINDPA,PLIST) ;Add to the patient list
+ ;for a regular file.
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DATA,DFN,FLIST
+ N ICOND,IND,IPLIST
+ N NOCC,NOCCABS,NFOUND,NGET,NP,PARAM,ROUTINE
+ N SAVE,SOURCE,STATUSA,TEMP,TEXT,TGLIST,TPLIST,TYPE
+ N UCIFS,VALUE,VSLIST
+ S TEMP=^PXRMD(811.4,CFIEN,0)
+ S TYPE=$P(TEMP,U,5)
+ I TYPE'="L" Q
+ S TGLIST="GPLIST_PXRMCF"
+ S PARAM=PFINDPA(15)
+ S SOURCE=FILENUM_";"_CFIEN
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ S NOCCABS=$$ABS^XLFMTH(NOCC)
+ D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCCABS)
+ K ^TMP($J,TGLIST)
+ S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(NGET,BDT,EDT,TGLIST,PARAM)"
+ D @ROUTINE
+ ;Routine should return:
+ ;^TMP($J,TGLIST,DFN,N)=DAS_U_DATE_U_FILENUM_U_ITEM_U_VALUE
+ ;Data values for condition are returned in
+ ;^TMP($J,TGLIST,DFN,N,SUB)=DATA(SUB)
+ S DFN=""
+ F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
+ . K TPLIST
+ . M TPLIST=^TMP($J,TGLIST,DFN)
+ . S (IND,NFOUND)=0
+ . K IPLIST
+ . F  S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCCABS)  D
+ .. S TEMP=TPLIST(IND)
+ .. K DATA M DATA=TPLIST(IND)
+ .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.DATA),1:1)
+ .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ .. I SAVE D
+ ... S NFOUND=NFOUND+1
+ ... S IPLIST(CONVAL,DFN,NFOUND,SOURCE)=TEMP
+ . M ^TMP($J,PLIST)=IPLIST
+ K ^TMP($J,TGLIST)
+ Q
+ ;
+ ;=======================================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N DATA,DATE,FIEN,IND,JND,NAME,NOUT,PNAME,TEMP,TEXTOUT,VALUE
+ S FIEN=$P(IFIEVAL("FINDING"),";",1)
+ S TEMP=^PXRMD(811.4,FIEN,0)
+ S PNAME=$P(TEMP,U,4)
+ I PNAME="" S PNAME=$P(TEMP,U,1)
+ S NAME="Computed Finding: "_PNAME_" = "
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S VALUE=$G(IFIEVAL(IND,"VALUE"))
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S TEMP=NAME_VALUE_" ("_$$EDATE^PXRMDATE(DATE)_")"
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;=======================================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ N DATA,DATE,FIEN,IND,JND,NOUT,PNAME,TEMP,TEXTOUT,VALUE
+ S FIEN=$P(IFIEVAL("FINDING"),";",1)
+ S TEMP=^PXRMD(811.4,FIEN,0)
+ S PNAME=$P(TEMP,U,4)
+ I PNAME="" S PNAME=$P(TEMP,U,1)
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Computed Finding: "_PNAME
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S TEMP=$$EDATE^PXRMDATE(DATE)
+ . S VALUE=$G(IFIEVAL(IND,"VALUE"))
+ . I VALUE'="" S TEMP=TEMP_" value - "_VALUE
+ .;If there is text append it.
+ . I $G(IFIEVAL(IND,"TEXT"))'="" S TEMP=TEMP_"; "_IFIEVAL(IND,"TEXT")
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m

@@ -1 @@
-PXRMCOND        ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;============================================================
-CASESEN(X,DA,FILENUM)   ;
-        ;Called by xref on condition case sensitive field in 811.5 and 811.9.
-        N COND,GBL
-        S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
-        S GBL=GBL_DA(1)_",20,"_DA_",3)"
-        S COND=$P(@GBL,U,1)
-        D SICOND(COND,.DA,FILENUM)
-        Q
-        ;
-        ;============================================================
-COND(CASESEN,ICOND,VSLIST,VA)   ;Evaluate the condition.
-        N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
-        S CONVAL=""
-        ;If there is no condition return true.
-        I $L($G(ICOND))=0 Q 1
-        S NSTAR=0
-        F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB=""  D
-        . I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB
-        S V=$G(VA("VALUE"))
-        I 'CASESEN S V=$$UP^XLFSTR(V)
-        ;Move all non "*" elements of VA into V.
-        I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA)
-        I NSTAR=0 X ICOND S CONVAL=$T
-        I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
-        Q CONVAL
-        ;
-        ;============================================================
-KICOND(X,DA,FILENUM)    ;
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        S FILENUM=$G(FILENUM)
-        I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
-        I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
-        Q
-        ;
-        ;============================================================
-MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
-        ;into V and uppercase if necessary.
-        N IND,NE,RV,RVA,SUB
-        S NE=$L(VSLIST,";")-1
-        F IND=1:1:NE D
-        . S SUB=$P(VSLIST,";",IND)
-        . I SUB["*" Q
-        . S RV="V("_SUB_")",RVA="VA("_SUB_")"
-        .;If VA(SUB) does not exist skip it.
-        . I '$D(@RVA) Q
-        . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
-        Q
-        ;
-        ;============================================================
-RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
-        ;first substitutes V array elements with "*" in subscript with a
-        ;replacement value. Once all have been replaced test condition and
-        ;quit if true. If not true continue until all combinations have been
-        ;tested.
-        N JND,RV,RVA,VSUB,VASUB
-        F JND=1:1:NM(IND) Q:CONVAL  D
-        . S VASUB=VM(IND,JND)
-        . S RVA="VA("_VASUB_")"
-        . S SUB=$P(VSTAR(IND),U,2)
-        . S RV="V("_SUB_")"
-        . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
-        . I IND<NSTAR D RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
-        . I IND=NSTAR X ICOND S CONVAL=$T
-        ;If there were no substitutions to make, make sure the condition is
-        ;evaluated.
-        I 'CONVAL,IND=NSTAR,NM(IND)=0 X ICOND S CONVAL=$T
-        Q
-        ;
-        ;============================================================
-SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST)   ;Set the Condition parameters.
-        N CONDS
-        S CONDS=$G(FINDPA(3))
-        S COND=$P(CONDS,U,1)
-        ;Even if there is no condition UCIFS could be used for status search.
-        S UCIFS=$P(CONDS,U,3)
-        I COND="" Q
-        S CASESEN=$P(CONDS,U,2)
-        I CASESEN="" S CASESEN=1
-        S ICOND=FINDPA(10),VSLIST=FINDPA(11)
-        Q
-        ;
-        ;============================================================
-SICOND(X,DA,FILENUM)    ;Set the internal condition field. Wrap all V() in $G.
-        ;Called by xref on condition field in 811.5 and 811.9.
-        I X="" Q
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        N CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
-        S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
-        S GBL=GBL_DA(1)_",20,"_DA_",3)"
-        S CASESEN=$P(@GBL,U,2)
-        I CASESEN="" S CASESEN=1
-        ;Find each V("sub") entry.
-        S XUP=$$UP^XLFSTR(X)
-        I 'CASESEN S (ICOND,X)=XUP
-        I CASESEN S ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
-        S SS=1,VSLIST=""
-        F  S SS=$F(XUP,"V(",SS) Q:SS=0  D
-        . S SE=$F(X,")",SS)
-        . S SUB=$E(X,SS,SE-2)
-        . I $D(SUBLIST(SUB)) Q
-        . S SUBLIST(SUB)=""
-        . S VSLIST=VSLIST_SUB_";"
-        . S VWSUB="V("_SUB_")"
-        . S TEMP="$G("_VWSUB_")"
-        . S ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
-        I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,DA,10)=ICOND,^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
-        I FILENUM=811.9 S ^PXD(811.9,DA(1),20,DA,10)=ICOND,^PXD(811.9,DA(1),20,DA,11)=VSLIST
-        Q
-        ;
-        ;============================================================
-STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR)        ;Execute a star condition,
-        ;look for any replacements for the * subscripts that will make the
-        ;Condition true.
-        N CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
-        N VASUB,VSSUB,VM
-        ;Build a list of the subscripts in VA.
-        S NVA=0,REF="VA"
-        F  S REF=$Q(@REF) Q:REF=""  D
-        . S SUB=$P(REF,"(",2)
-        . S SUB=$P(SUB,")",1)
-        . S SUBL=$L(SUB,",")
-        . S NVA=NVA+1,VASUB(NVA)=SUBL_U_SUB
-        ;Build a list of replacements for the * subscripts.
-        F IND=1:1:NSTAR D
-        . S NM=0
-        . S VSSUB=$P(VSTAR(IND),U,2)
-        . S SUBL=+VSTAR(IND)
-        . F JND=1:1:NVA D
-        .. I +VASUB(JND)'=SUBL Q
-        .. S SUB=$P(VASUB(JND),U,2)
-        .. S MATCH=1
-        .. F KND=1:1:SUBL D
-        ... S TEMP=$P(VSSUB,",",KND)
-        ... I TEMP["*" Q
-        ... I $P(SUB,",",KND)'=TEMP S MATCH=0,KND=SUBL
-        .. I MATCH S NM=NM+1,VM(IND,NM)=SUB
-        . S NM(IND)=NM
-        S CONVAL=0
-        F IND=1:1:NSTAR Q:CONVAL  D RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
-        Q CONVAL
-        ;
-        ;============================================================
-VCOND(X)        ;
-        ;Input transform on Condition field.
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q 1
-        ;The CONDITION must start with "I ".
-        S X=$$UP^XLFSTR(X)
-        I $E(X,1,2)'="I " D  Q 0
-        . S X=""
-        . D EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
-        ;The CONDITION cannot contain "^".
-        I X["^" D  Q 0
-        . S X=""
-        . D EN^DDIOL("CONDITION cannot contain ""^""")
-        ;The CONDITION cannot contain "@".
-        I X["@" D  Q 0
-        . S X=""
-        . D EN^DDIOL("CONDITION cannot contain ""@""")
-        ;The rest of the condition can only contain spaces if they are in
-        ;a string.
-        N COND,TEMP,VALID
-        S COND=$E(X,3,$L(X))
-        S VALID=$S(COND[" ":$$VSPACE(COND),1:1)
-        I VALID S VALID=$S(COND["V(":$$VSUB(COND),1:1)
-        I VALID D
-        . D ^DIM
-        . I '$D(X) D
-        .. D EN^DDIOL("Not a valid MUMPS string")
-        .. S VALID=0
-        Q VALID
-        ;
-        ;============================================================
-VSPACE(COND)    ;Make sure all spaces in the condition that come after
-        ;the beginning I are inside a quoted string.
-        N CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
-        S VALID=1
-        S (LQ,NQP,NSP)=0
-        F IND=1:1:$L(COND) D
-        . S CHAR=$E(COND,IND)
-        . I CHAR="""" D
-        .. I LQ S NQP=NQP+1,QP(NQP)=LQ_U_IND,LQ=0
-        .. E  S LQ=IND
-        . I CHAR=" " S NSP=NSP+1,SP(NSP)=IND
-        S NIQ=0
-        F IND=1:1:NSP D
-        . S SPACE=SP(NSP)
-        . S IQ=0
-        . F JND=1:1:NQP D
-        .. I SPACE>$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q
-        . S NIQ=$S(IQ:0,1:1)
-        . I NIQ S IND=NSP Q
-        I NIQ D
-        . D EN^DDIOL("No spaces are allowed except in quoted strings!")
-        . S VALID=0
-        Q VALID
-        ;
-        ;============================================================
-VSUB(COND)      ;Make sure all V subscripts are quoted strings, numbers
-        ;or quoted * strings.
-        N IND,RP,SS,SUB,SUBL,VALID
-        S (SS,VALID)=1
-        F  S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0)  D
-        . S RP=$F(COND,")",SS)-2
-        . I RP=-2 D  Q
-        .. N TEXT
-        .. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")"""
-        .. D EN^DDIOL(TEXT)
-        .. S VALID=0
-        . S SUBL=$E(COND,SS,RP)
-        . F IND=1:1:$L(SUBL,",") D
-        .. S SUB=$P(SUBL,",",IND)
-        ..;Check for a number.
-        .. I SUB=+SUB Q
-        ..;Check for a wildcard, must be in quotes any number of * allowed.
-        .. I SUB?1"""1"*"."*"""" Q
-        .. ;Check for first and last character = to a ".
-        .. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0
-        I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
-        Q VALID
-        ;
+PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;11/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;============================================================
+CASESEN(X,DA,FILENUM) ;
+ ;Called by xref on condition case sensitive field in 811.5 and 811.9.
+ N COND,GBL
+ S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+ S GBL=GBL_DA(1)_",20,"_DA_",3)"
+ S COND=$P(@GBL,U,1)
+ D SICOND(COND,.DA,FILENUM)
+ Q
+ ;
+ ;============================================================
+COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition.
+ N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
+ S CONVAL=""
+ ;If there is no condition return true.
+ I $L($G(ICOND))=0 Q 1
+ S NSTAR=0
+ F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB=""  D
+ . I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB
+ S V=$G(VA("VALUE"))
+ I 'CASESEN S V=$$UP^XLFSTR(V)
+ ;Move all non "*" elements of VA into V.
+ I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA)
+ I NSTAR=0 X ICOND S CONVAL=$T
+ I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
+ Q CONVAL
+ ;
+ ;============================================================
+KICOND(X,DA,FILENUM) ;
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ S FILENUM=$G(FILENUM)
+ I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
+ I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
+ Q
+ ;
+ ;============================================================
+MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
+ ;into V and uppercase if necessary.
+ N IND,NE,RV,RVA,SUB
+ S NE=$L(VSLIST,";")-1
+ F IND=1:1:NE D
+ . S SUB=$P(VSLIST,";",IND)
+ . I SUB["*" Q
+ . S RV="V("_SUB_")",RVA="VA("_SUB_")"
+ .;If VA(SUB) does not exist skip it.
+ . I '$D(@RVA) Q
+ . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
+ Q
+ ;
+ ;============================================================
+RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
+ ;first substitutes V array elements with "*" in subscript with a
+ ;replacement value. Once all have been replaced test condition and
+ ;quit if true. If not true continue until all combinations have been
+ ;tested.
+ N JND,RV,RVA,VSUB,VASUB
+ F JND=1:1:NM(IND) Q:CONVAL  D
+ . S VASUB=VM(IND,JND)
+ . S RVA="VA("_VASUB_")"
+ . S SUB=$P(VSTAR(IND),U,2)
+ . S RV="V("_SUB_")"
+ . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
+ . I IND<NSTAR D RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
+ . I IND=NSTAR X ICOND S CONVAL=$T
+ ;If there were no substitutions to make, make sure the condition is
+ ;evaluated.
+ I 'CONVAL,IND=NSTAR,NM(IND)=0 X ICOND S CONVAL=$T
+ Q
+ ;
+ ;============================================================
+SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
+ N CONDS
+ S CONDS=$G(FINDPA(3))
+ S COND=$P(CONDS,U,1)
+ S UCIFS=$S(COND="":0,1:$P(CONDS,U,3))
+ I COND="" Q
+ S CASESEN=$P(CONDS,U,2)
+ I CASESEN="" S CASESEN=1
+ S ICOND=FINDPA(10),VSLIST=FINDPA(11)
+ Q
+ ;
+ ;============================================================
+SICOND(X,DA,FILENUM) ;Set the internal condition field. Wrap all V() in $G.
+ ;Called by xref on condition field in 811.5 and 811.9.
+ I X="" Q
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ N CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
+ S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+ S GBL=GBL_DA(1)_",20,"_DA_",3)"
+ S CASESEN=$P(@GBL,U,2)
+ I CASESEN="" S CASESEN=1
+ ;Find each V("sub") entry.
+ S XUP=$$UP^XLFSTR(X)
+ I 'CASESEN S (ICOND,X)=XUP
+ I CASESEN S ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
+ S SS=1,VSLIST=""
+ F  S SS=$F(XUP,"V(",SS) Q:SS=0  D
+ . S SE=$F(X,")",SS)
+ . S SUB=$E(X,SS,SE-2)
+ . I $D(SUBLIST(SUB)) Q
+ . S SUBLIST(SUB)=""
+ . S VSLIST=VSLIST_SUB_";"
+ . S VWSUB="V("_SUB_")"
+ . S TEMP="$G("_VWSUB_")"
+ . S ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
+ I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,DA,10)=ICOND,^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
+ I FILENUM=811.9 S ^PXD(811.9,DA(1),20,DA,10)=ICOND,^PXD(811.9,DA(1),20,DA,11)=VSLIST
+ Q
+ ;
+ ;============================================================
+STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR) ;Execute a star condition,
+ ;look for any replacements for the * subscripts that will make the
+ ;Condition true.
+ N CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
+ N VASUB,VSSUB,VM
+ ;Build a list of the subscripts in VA.
+ S NVA=0,REF="VA"
+ F  S REF=$Q(@REF) Q:REF=""  D
+ . S SUB=$P(REF,"(",2)
+ . S SUB=$P(SUB,")",1)
+ . S SUBL=$L(SUB,",")
+ . S NVA=NVA+1,VASUB(NVA)=SUBL_U_SUB
+ ;Build a list of replacements for the * subscripts.
+ F IND=1:1:NSTAR D
+ . S NM=0
+ . S VSSUB=$P(VSTAR(IND),U,2)
+ . S SUBL=+VSTAR(IND)
+ . F JND=1:1:NVA D
+ .. I +VASUB(JND)'=SUBL Q
+ .. S SUB=$P(VASUB(JND),U,2)
+ .. S MATCH=1
+ .. F KND=1:1:SUBL D
+ ... S TEMP=$P(VSSUB,",",KND)
+ ... I TEMP["*" Q
+ ... I $P(SUB,",",KND)'=TEMP S MATCH=0,KND=SUBL
+ .. I MATCH S NM=NM+1,VM(IND,NM)=SUB
+ . S NM(IND)=NM
+ S CONVAL=0
+ F IND=1:1:NSTAR Q:CONVAL  D RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
+ Q CONVAL
+ ;
+ ;============================================================
+VCOND(X) ;
+ ;Input transform on Condition field.
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q 1
+ ;The CONDITION must start with "I ".
+ S X=$$UP^XLFSTR(X)
+ I $E(X,1,2)'="I " D  Q 0
+ . S X=""
+ . D EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
+ ;The CONDITION cannot contain "^".
+ I X["^" D  Q 0
+ . S X=""
+ . D EN^DDIOL("CONDITION cannot contain ""^""")
+ ;The CONDITION cannot contain "@".
+ I X["@" D  Q 0
+ . S X=""
+ . D EN^DDIOL("CONDITION cannot contain ""@""")
+ ;The rest of the condition can only contain spaces if they are in
+ ;a string.
+ N COND,TEMP,VALID
+ S COND=$E(X,3,$L(X))
+ S VALID=$S(COND[" ":$$VSPACE(COND),1:1)
+ I VALID S VALID=$S(COND["V(":$$VSUB(COND),1:1)
+ I VALID D
+ . D ^DIM
+ . I '$D(X) D
+ .. D EN^DDIOL("Not a valid MUMPS string")
+ .. S VALID=0
+ Q VALID
+ ;
+ ;============================================================
+VSPACE(COND) ;Make sure all spaces in the condition that come after
+ ;the beginning I are inside a quoted string.
+ N CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
+ S VALID=1
+ S (LQ,NQP,NSP)=0
+ F IND=1:1:$L(COND) D
+ . S CHAR=$E(COND,IND)
+ . I CHAR="""" D
+ .. I LQ S NQP=NQP+1,QP(NQP)=LQ_U_IND,LQ=0
+ .. E  S LQ=IND
+ . I CHAR=" " S NSP=NSP+1,SP(NSP)=IND
+ S NIQ=0
+ F IND=1:1:NSP D
+ . S SPACE=SP(NSP)
+ . S IQ=0
+ . F JND=1:1:NQP D
+ .. I SPACE>$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q
+ . S NIQ=$S(IQ:0,1:1)
+ . I NIQ S IND=NSP Q
+ I NIQ D
+ . D EN^DDIOL("No spaces are allowed except in quoted strings!")
+ . S VALID=0
+ Q VALID
+ ;
+ ;============================================================
+VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers
+ ;or quoted * strings.
+ N IND,RP,SS,SUB,SUBL,VALID
+ S (SS,VALID)=1
+ F  S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0)  D
+ . S RP=$F(COND,")",SS)-2
+ . I RP=-2 D  Q
+ .. N TEXT
+ .. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")"""
+ .. D EN^DDIOL(TEXT)
+ .. S VALID=0
+ . S SUBL=$E(COND,SS,RP)
+ . F IND=1:1:$L(SUBL,",") D
+ .. S SUB=$P(SUBL,",",IND)
+ ..;Check for a number.
+ .. I SUB=+SUB Q
+ ..;Check for a wildcard, must be in quotes any number of * allowed.
+ .. I SUB?1"""1"*"."*"""" Q
+ .. ;Check for first and last character = to a ".
+ .. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0
+ I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
+ Q VALID
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m

@@ -1 @@
-PXRMCOPY        ; SLC/PKR,PJH - Copy various reminder files. ;09/13/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=====================================================
-COPY(PROMPT,ROOT,WHAT)  ;Copy an entry of ROOT into a new entry.
-        N DIROUT,DTOUT,DUOUT
-        F  D GETORGR Q:$D(DIROUT)  Q:$D(DTOUT)
-        Q
-        ;
-        ;=====================================================
-GETORGR ;Look-up logic to get and copy source entry to destination.
-        N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
-        N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
-        S DIC=ROOT,DIC(0)="AEMQ",DIC("A")=PROMPT
-        W !
-        D ^DIC
-        I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
-        S IENO=$P(Y,U,1)
-        I IENO=-1 S DIROUT="" Q
-        ;
-        ;Set the starting place for additions.
-        D SETSTART^PXRMCOPY(DIC)
-        S IENN=$$GETFOIEN(ROOT)
-        D MERGE(IENN,IENO,ROOT)
-        ;
-        ;Get the new name.
-        S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1)
-        S FILE=$$FNFR^PXRMUTIL(ROOT)
-        S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
-        S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
-        S DIR("A")="PLEASE ENTER A UNIQUE NAME"
-GETNAM  D ^DIR
-        I $D(DIRUT) D DELETE(ROOT,IENN) Q
-        S NAME=Y
-        ;
-        ;Make sure the new name is valid.
-        I '$$VNAME^PXRMINTR(NAME,FILE) G GETNAM
-        ;
-        ;Change to the new name.
-        S IENS=IENN_","
-        S FDA(FILE,IENS,.01)=NAME
-        K MSG
-        D FILE^DIE("","FDA","MSG")
-        ;Check to make sure the name was not a duplicate.
-        I $G(MSG("DIERR",1))=740 D  G GETNAM
-        . W !,NAME," is not a unique name!"
-        ;Change the class to local and delete the sponsor.
-        D SCAS(FILE,IENN,"L","")
-        ;Initialize the edit history.
-        D INIEH(FILE,ROOT,IENN,IENO)
-        ;
-        ;Reindex the cross-references.
-        S DIK=ROOT,DA=IENN
-        D IX^DIK
-        W !
-        ;
-        ;Tell the user what has happened and allow for editing of the new item.
-        S DIR(0)="Y"
-        S DIR("A")="Do you want to edit it now"
-        S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
-        D ^DIR Q:$D(DIRUT)
-        I Y D EDIT^PXRMEDIT(ROOT,IENN)
-        Q
-        ;
-        ;=====================================================
-COPYLL  ;Copy a location list.
-        N PROMPT,ROOT,WHAT
-        S WHAT="location list"
-        S ROOT="^PXRMD(810.9,"
-        S PROMPT="Select the reminder location list to copy: "
-        D COPY(PROMPT,ROOT,WHAT)
-        Q
-        ;
-        ;=====================================================
-COPYREM ;Copy a reminder definition.
-        N PROMPT,ROOT,WHAT
-        S WHAT="reminder"
-        S ROOT="^PXD(811.9,"
-        S PROMPT="Select the reminder definition to copy: "
-        D COPY(PROMPT,ROOT,WHAT)
-        Q
-        ;
-        ;=====================================================
-COPYTAX ;Copy a taxonomy.
-        N PROMPT,ROOT,WHAT
-        S WHAT="taxonomy"
-        S ROOT="^PXD(811.2,"
-        S PROMPT="Select the reminder taxonomy to copy: "
-        D COPY(PROMPT,ROOT,WHAT)
-        Q
-        ;
-        ;=====================================================
-COPYTERM        ;Copy a reminder term.
-        N PROMPT,ROOT,WHAT
-        S WHAT="reminder term"
-        S ROOT="^PXRMD(811.5,"
-        S PROMPT="Select the reminder term to copy: "
-        D COPY(PROMPT,ROOT,WHAT)
-        Q
-        ;
-        ;=====================================================
-DELETE(DIK,DA)  ;Delete the entry just added. 
-        D ^DIK
-        W !!,"New entry not created due to invalid name!",!
-        Q
-        ;
-        ;=====================================================
-GETFOIEN(ROOT)  ;Return the first open IEN in ROOT. This should be called
-        ;after a call to SETSTART.
-        N ENTRY,NIEN,OIEN
-        S ENTRY=ROOT_0_")"
-        S OIEN=$P(@ENTRY,U,3)
-        S ENTRY=ROOT_OIEN_")"
-        F  S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1  Q:+NIEN'>0  S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
-        Q OIEN+1
-        ;
-        ;=====================================================
-INIEH(FILENUM,ROOT,IENN,IENO)   ;Initialize the edit history after a copy.
-        ;First delete any existing history entries.
-        N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
-        D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
-        S SFN=+$G(TARGET("SPECIFIER"))
-        I SFN=0 Q
-        S ENTRY=ROOT_IENN_",110)"
-        S IND=0
-        F  S IND=$O(@ENTRY@(IND)) Q:+IND=0  D
-        . S IENS=IND_","_IENN_","
-        . S FDA(SFN,IENS,.01)="@"
-        I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG")
-        I $D(MSG) D AWRITE^PXRMUTIL("MSG")
-        ;Establish an initial entry in the edit history.
-        K FDA,MSG
-        S IENS="+1,"_IENN_","
-        S FDAIEN(IENN)=IENN
-        S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
-        S FDA(SFN,IENS,2)="WP(1,1)"
-        S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
-        D UPDATE^DIE("E","FDA","FDAIEN","MSG")
-        I $D(MSG) D AWRITE^PXRMUTIL("MSG")
-        Q
-        ;
-        ;=====================================================
-MERGE(IENN,IENO,ROOT)   ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
-        N DEST,SOURCE
-        S DEST=ROOT_IENN_")"
-        ;Lock the file before merging.
-        L +@DEST:10
-        S SOURCE=ROOT_IENO_")"
-        M @DEST=@SOURCE
-        ;Unlock the file
-        L -@DEST
-        Q
-        ;
-        ;=====================================================
-SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
-        ;field to SPONSOR.
-        N IENS,FDA,MSG
-        S IENS=IEN_","
-        S FDA(FILENUM,IENS,100)=CLASS
-        S FDA(FILENUM,IENS,101)=SPONSOR
-        D FILE^DIE("K","FDA","MSG")
-        I $D(MSG) D AWRITE^PXRMUTIL("MSG")
-        Q
-        ;
-        ;=====================================================
-SETSTART(ROOT)  ;Set the starting value to add new entries. Start
-        ;at the begining so empty spaces are filled in.
-        N CUR,ENTRY
-        S ENTRY=ROOT_"0)"
-        S $P(@ENTRY,U,3)=1
-        Q
-        ;
+PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=====================================================
+COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
+ N DIROUT,DTOUT,DUOUT
+ F  D GETORGR Q:$D(DIROUT)  Q:$D(DTOUT)
+ Q
+ ;
+ ;=====================================================
+GETORGR ;Look-up logic to get and copy source entry to destination.
+ N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
+ N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
+ S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT
+ W !
+ D ^DIC
+ I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
+ S IENO=$P(Y,U,1)
+ I IENO=-1 S DIROUT="" Q
+ ;
+ ;Set the starting place for additions.
+ D SETSTART^PXRMCOPY(DIC)
+ S IENN=$$GETFOIEN(ROOT)
+ D MERGE(IENN,IENO,ROOT)
+ ;
+ ;Get the new name.
+ S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1)
+ S FILE=$$FNFR^PXRMUTIL(ROOT)
+ S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH")
+ S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X"
+ S DIR("A")="PLEASE ENTER A UNIQUE NAME"
+GETNAM D ^DIR
+ I $D(DIRUT) D DELETE(ROOT,IENN) Q
+ S NAME=Y
+ ;
+ ;Make sure the new name is valid.
+ I '$$VNAME^PXRMINTR(NAME,FILE) G GETNAM
+ ;
+ ;Change to the new name.
+ S IENS=IENN_","
+ S FDA(FILE,IENS,.01)=NAME
+ K MSG
+ D FILE^DIE("","FDA","MSG")
+ ;Check to make sure the name was not a duplicate.
+ I $G(MSG("DIERR",1))=740 D  G GETNAM
+ . W !,NAME," is not a unique name!"
+ ;Change the class to local and delete the sponsor.
+ D SCAS(FILE,IENN,"L","")
+ ;Initialize the edit history.
+ D INIEH(FILE,ROOT,IENN,IENO)
+ ;
+ ;Reindex the cross-references.
+ S DIK=ROOT,DA=IENN
+ D IX^DIK
+ W !
+ ;
+ ;Tell the user what has happened and allow for editing of the new item.
+ S DIR(0)="Y"
+ S DIR("A")="Do you want to edit it now"
+ S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"."
+ D ^DIR Q:$D(DIRUT)
+ I Y D EDIT^PXRMEDIT(ROOT,IENN)
+ Q
+ ;
+ ;=====================================================
+COPYREM ;Copy a reminder definition.
+ N PROMPT,ROOT,WHAT
+ S WHAT="reminder"
+ S ROOT="^PXD(811.9,"
+ S PROMPT="Select the reminder item to copy: "
+ D COPY(PROMPT,ROOT,WHAT)
+ Q
+ ;
+ ;=====================================================
+COPYTAX ;Copy a taxonomy.
+ N PROMPT,ROOT,WHAT
+ S WHAT="taxonomy"
+ S ROOT="^PXD(811.2,"
+ S PROMPT="Select the taxonomy item to copy: "
+ D COPY(PROMPT,ROOT,WHAT)
+ Q
+ ;
+ ;=====================================================
+COPYTERM ;Copy a reminder term.
+ N PROMPT,ROOT,WHAT
+ S WHAT="reminder term"
+ S ROOT="^PXRMD(811.5,"
+ S PROMPT="Select the reminder term to copy: "
+ D COPY(PROMPT,ROOT,WHAT)
+ Q
+ ;
+ ;=====================================================
+DELETE(DIK,DA) ;Delete the entry just added. 
+ D ^DIK
+ W !!,"New entry not created due to invalid name!",!
+ Q
+ ;
+ ;=====================================================
+GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called
+ ;after a call to SETSTART.
+ N ENTRY,NIEN,OIEN
+ S ENTRY=ROOT_0_")"
+ S OIEN=$P(@ENTRY,U,3)
+ S ENTRY=ROOT_OIEN_")"
+ F  S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1  Q:+NIEN'>0  S OIEN=NIEN,ENTRY=ROOT_NIEN_")"
+ Q OIEN+1
+ ;
+ ;=====================================================
+INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy.
+ ;First delete any existing history entries.
+ N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP
+ D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
+ S SFN=+$G(TARGET("SPECIFIER"))
+ I SFN=0 Q
+ S ENTRY=ROOT_IENN_",110)"
+ S IND=0
+ F  S IND=$O(@ENTRY@(IND)) Q:+IND=0  D
+ . S IENS=IND_","_IENN_","
+ . S FDA(SFN,IENS,.01)="@"
+ I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG")
+ I $D(MSG) D AWRITE^PXRMUTIL("MSG")
+ ;Establish an initial entry in the edit history.
+ K FDA,MSG
+ S IENS="+1,"_IENN_","
+ S FDAIEN(IENN)=IENN
+ S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
+ S FDA(SFN,IENS,2)="WP(1,1)"
+ S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01)
+ D UPDATE^DIE("E","FDA","FDAIEN","MSG")
+ I $D(MSG) D AWRITE^PXRMUTIL("MSG")
+ Q
+ ;
+ ;=====================================================
+MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN.
+ N DEST,SOURCE
+ S DEST=ROOT_IENN_")"
+ ;Lock the file before merging.
+ L +@DEST:10
+ S SOURCE=ROOT_IENO_")"
+ M @DEST=@SOURCE
+ ;Unlock the file
+ L -@DEST
+ Q
+ ;
+ ;=====================================================
+SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor
+ ;field to SPONSOR.
+ N IENS,FDA,MSG
+ S IENS=IEN_","
+ S FDA(FILENUM,IENS,100)=CLASS
+ S FDA(FILENUM,IENS,101)=SPONSOR
+ D FILE^DIE("K","FDA","MSG")
+ I $D(MSG) D AWRITE^PXRMUTIL("MSG")
+ Q
+ ;
+ ;=====================================================
+SETSTART(ROOT) ;Set the starting value to add new entries. Start
+ ;at the begining so empty spaces are filled in.
+ N CUR,ENTRY
+ S ENTRY=ROOT_"0)"
+ S $P(@ENTRY,U,3)=1
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m

@@ -1 @@
-PXRMDATA        ; SLC/PKR - Routines for getting data. ;04/02/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;===============================================
-GETDATA(FILENUM,DAS,FIEVT)      ;Return data for a finding.
-        K FIEVT
-        I FILENUM=45 D GETDATA^PXRMDGPT(DAS,.FIEVT) Q
-        I FILENUM=52 D GETDATA^PXRMDOUT(DAS,.FIEVT) Q
-        I FILENUM=55 D GETDATA^PXRMDIN(DAS,.FIEVT)  Q
-        I FILENUM="55NVA" D GETDATA^PXRMDNVA(DAS,.FIEVT) Q
-        I FILENUM=63 D GETDATA^PXRMLAB(DAS,.FIEVT) Q
-        I FILENUM=70 D GETDATA^PXRMRAD(DAS,.FIEVT) Q
-        I FILENUM=100 D GETDATA^PXRMORDR(DAS,.FIEVT) Q
-        I FILENUM=120.5 D GETDATA^PXRMVITL(DAS,.FIEVT) Q
-        I FILENUM=601.84 D GETDATA^PXRMMH(DAS,.FIEVT) Q
-        I FILENUM=9000010 D GETDATA^PXRMVSIT(DAS,.FIEVT,1) Q
-        I FILENUM=9000010.07 D GETDATA^PXRMVPOV(DAS,.FIEVT) Q
-        I FILENUM=9000010.11 D GETDATA^PXRMIMM(DAS,.FIEVT) Q
-        I FILENUM=9000010.12 D GETDATA^PXRMSKIN(DAS,.FIEVT) Q
-        I FILENUM=9000010.13 D GETDATA^PXRMEXAM(DAS,.FIEVT) Q
-        I FILENUM=9000010.16 D GETDATA^PXRMEDU(DAS,.FIEVT) Q
-        I FILENUM=9000010.18 D GETDATA^PXRMVCPT(DAS,.FIEVT) Q
-        I FILENUM=9000010.23 D GETDATA^PXRMHF(DAS,.FIEVT) Q
-        I FILENUM=9000011 D GETDATA^PXRMPROB(DAS,.FIEVT) Q
-        Q
-        ;
-        ;===============================================
-GETFNAME(FINDING)       ;Given a finding of the form IEN;GLOBAL return its name.
-        N DIC,DO,IEN,FNUM,GLOBAL
-        S IEN=$P(FINDING,";",1)
-        S GLOBAL=$P(FINDING,";",2)
-        S GLOBAL=$S(GLOBAL="PS(55NVA,":"PS(50.7,",GLOBAL="PS(55,":"PSDRUG(",1:GLOBAL)
-        S DIC="^"_GLOBAL
-        D DO^DIC1
-        S FNUM=+$P(DO,U,2)
-        Q $$GET1^DIQ(FNUM,IEN,.01)
-        ;
-        ;===============================================
-GETFNUM(ENODE)  ;Given an ENODE return the file number for the data source.
-        I ENODE="AUTTEDT(" Q 9000010.16
-        I ENODE="AUTTEXAM(" Q 9000010.13
-        I ENODE="AUTTHF(" Q 9000010.23
-        I ENODE="AUTTIMM(" Q 9000010.11
-        I ENODE="AUTTSK(" Q 9000010.12
-        I ENODE="GMRD(120.51," Q 120.5
-        I ENODE="LAB(60," Q 63
-        I ENODE="ORD(101.43," Q 100
-        I ENODE="PXD(811.2," Q 811.2
-        I ENODE="PXRMD(810.9," Q 9000010
-        I ENODE="PXRMD(811.4," Q 811.4
-        I ENODE="PXRMD(811.5," Q 811.5
-        I ENODE="PS(50.605," Q 52_U_55_U_"55NVA"
-        I ENODE="PS(55," Q 55
-        I ENODE="PS(55NVA," Q "55NVA"
-        I ENODE="PSDRUG(" Q 52_U_55_U_"55NVA"
-        I ENODE="PSNDF(50.6," Q 52_U_55_U_"55NVA"
-        I ENODE="PSRX(" Q 52
-        I ENODE="RAMIS(71," Q 70
-        I ENODE="YTT(601.71," Q 601.84
-        Q 0
-        ;
+PXRMDATA ; SLC/PKR - Routines for getting data. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;===============================================
+GETDATA(FILENUM,DAS,FIEVT) ;Return data for a finding.
+ K FIEVT
+ I FILENUM=45 D GETDATA^PXRMDGPT(DAS,.FIEVT) Q
+ I FILENUM=52 D GETDATA^PXRMDOUT(DAS,.FIEVT) Q
+ I FILENUM=55 D GETDATA^PXRMDIN(DAS,.FIEVT)  Q
+ I FILENUM="55NVA" D GETDATA^PXRMDNVA(DAS,.FIEVT) Q
+ I FILENUM=63 D GETDATA^PXRMLAB(DAS,.FIEVT) Q
+ I FILENUM=70 D GETDATA^PXRMRAD(DAS,.FIEVT) Q
+ I FILENUM=100 D GETDATA^PXRMORDR(DAS,.FIEVT) Q
+ I FILENUM=120.5 D GETDATA^PXRMVITL(DAS,.FIEVT) Q
+ I FILENUM=601.2 D GETDATA^PXRMMH(DAS,.FIEVT) Q
+ I FILENUM=9000010 D GETDATA^PXRMVSIT(DAS,.FIEVT,1) Q
+ I FILENUM=9000010.07 D GETDATA^PXRMVPOV(DAS,.FIEVT) Q
+ I FILENUM=9000010.11 D GETDATA^PXRMIMM(DAS,.FIEVT) Q
+ I FILENUM=9000010.12 D GETDATA^PXRMSKIN(DAS,.FIEVT) Q
+ I FILENUM=9000010.13 D GETDATA^PXRMEXAM(DAS,.FIEVT) Q
+ I FILENUM=9000010.16 D GETDATA^PXRMEDU(DAS,.FIEVT) Q
+ I FILENUM=9000010.18 D GETDATA^PXRMVCPT(DAS,.FIEVT) Q
+ I FILENUM=9000010.23 D GETDATA^PXRMHF(DAS,.FIEVT) Q
+ I FILENUM=9000011 D GETDATA^PXRMPROB(DAS,.FIEVT) Q
+ Q
+ ;
+ ;===============================================
+GETFNAME(FINDING) ;Given a finding of the form IEN;GLOBAL return its name.
+ N DIC,DO,IEN,FNUM,GLOBAL
+ S IEN=$P(FINDING,";",1)
+ S GLOBAL=$P(FINDING,";",2)
+ S GLOBAL=$S(GLOBAL="PS(55NVA,":"PS(50.7,",GLOBAL="PS(55,":"PSDRUG(",1:GLOBAL)
+ S DIC="^"_GLOBAL
+ D DO^DIC1
+ S FNUM=+$P(DO,U,2)
+ Q $$GET1^DIQ(FNUM,IEN,.01)
+ ;
+ ;===============================================
+GETFNUM(ENODE) ;Given an ENODE return the file number for the data source.
+ I ENODE="AUTTEDT(" Q 9000010.16
+ I ENODE="AUTTEXAM(" Q 9000010.13
+ I ENODE="AUTTHF(" Q 9000010.23
+ I ENODE="AUTTIMM(" Q 9000010.11
+ I ENODE="AUTTSK(" Q 9000010.12
+ I ENODE="GMRD(120.51," Q 120.5
+ I ENODE="LAB(60," Q 63
+ I ENODE="ORD(101.43," Q 100
+ I ENODE="PXD(811.2," Q 811.2
+ I ENODE="PXRMD(810.9," Q 9000010
+ I ENODE="PXRMD(811.4," Q 811.4
+ I ENODE="PXRMD(811.5," Q 811.5
+ I ENODE="PS(50.605," Q 52_U_55_U_"55NVA"
+ I ENODE="PS(55," Q 55
+ I ENODE="PS(55NVA," Q "55NVA"
+ I ENODE="PSDRUG(" Q 52_U_55_U_"55NVA"
+ I ENODE="PSNDF(50.6," Q 52_U_55_U_"55NVA"
+ I ENODE="PSRX(" Q 52
+ I ENODE="RAMIS(71," Q 70
+ I ENODE="YTT(601," Q 601.2
+ Q 0
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m

@@ -1 @@
-PXRMDATE        ; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;==================================================
-CEFD(FDA)       ;Called by the Exchange Utility only if the input packed
-        ;reminder was packed under v1.5  Move Effective Date to Beginning Date.
-        N IND
-        S IND=""
-        F  S IND=$O(FDA(811.902,IND)) Q:IND=""  D
-        . I '$D(FDA(811.902,IND,12)) Q
-        .;If the EFFECTIVE PERIOD exists don't do anything.
-        . I $D(FDA(811.902,IND,9)) Q
-        . S FDA(811.902,IND,9)=FDA(811.902,IND,12)
-        . K FDA(811.902,IND,12)
-        Q
-        ;
-        ;==================================================
-COMPARE(X)      ;Compare beginning and ending dates, give a warning if
-        ;Ending Date comes before Beginning Date. Called by ADATE xref in
-        ;definitions and terms.
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        N BDT,EDT
-        S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
-        S EDT=X(2)
-        I EDT="" S EDT="T"
-        S EDT=$$CTFMD^PXRMDATE(EDT)
-        ;If EDT does not contain a time set it to the end of the day.
-        I EDT'["." S EDT=EDT_".235959"
-        I EDT<BDT D
-        . S BDT=$S(X(1)'="":X(1),1:"")
-        . S EDT=$S(X(2)'="":X(2),1:"T@2400")
-        . S TEXT="Warning the ending date ("_EDT_") is before the beginning date ("_BDT_")"
-        . D EN^DDIOL(TEXT)
-        Q
-        ;
-        ;==================================================
-COTN(EFP)       ;Convert an Effective Period to the new date/time format.
-        ;Possible effective periods are ND, NM, or NY where N is an integer.
-        S EFP=$$UP^XLFSTR(EFP)
-        I (EFP?1N.N1"D")!(EFP?1N.N1"M")!(EFP?1N.N1"Y") D
-        . S NUM=+EFP
-        . S EFP=$S(NUM=0:"T",1:"T-"_EFP)
-        Q EFP
-        ;
-        ;==================================================
-CTFMD(DATE)     ;Convert DATE which may be in any of the FileMan acceptable
-        ;forms as well as T-NY to a FileMan date. Also understands LAD for
-        ;Last Admission Date.
-        N %DT,ND,X,Y
-        ;Already a FileMan date?
-        S ND=+DATE
-        I (ND'<1000000),(ND'>9991231) Q DATE
-        ;Check for a date FileMan understands.
-        S X=DATE,%DT="ST"
-        D ^%DT
-        ;If it is not a FileMan date check for a symbolic date.
-        I Y=-1 S Y=$$SYMDATE(DATE)
-        ;If it is not a date that is understood by SYMDATE return -1
-        I Y=-1 Q -1
-        I $G(PXRMDATE)'="",$$ISVSYMD(DATE) D
-        . N DIFFS
-        . S DIFFS=-$$FMDIFF^XLFDT(DT,PXRMDATE,2)
-        . S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
-        I DATE["LAD" D
-        . I $G(PXRMLAD)="" S Y=0
-        . E  D
-        .. N DIFFS
-        .. S DIFFS=-$$FMDIFF^XLFDT(DT,$G(PXRMLAD),2)
-        .. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
-        Q Y
-        ;
-        ;=================================================
-DCHECK(DATE)    ;Trap for special characters before calling CTFMD^PXRMDATE.
-        ;Used in DIR("PRE") for date inputs.
-        I $D(DTOUT) Q DATE
-        I DATE="" Q DATE
-        I DATE["^" Q DATE
-        I DATE["?" Q DATE
-        Q $$CTFMD^PXRMDATE(DATE)
-        ;
-        ;==================================================
-DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL)     ;Compute the due date.
-        ;This is the date of the resolution finding + the reminder frequency.
-        ;Subtract the due in advance time to see if the reminder should be
-        ;marked as due soon.
-        ;
-        N DATE,DIAT,DIATOK,LDATE,PXRMITEM,TDDUE,TODAY
-        S PXRMITEM=DEFARR("IEN")
-        ;If the final frequency is 0Y then the reminder is not due.
-        I FREQ="0Y" S DUE=0,DUEDATE="" Q
-        ;
-        S DUEDATE=""
-        ;Check for custom date due.
-        I DEFARR(45)'="" S DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL)
-        I DUEDATE'="",DUEDATE'=-1 G SETDUE
-        ;
-        ;No custom date due, do regular date calculation.
-        I (FREQ="")!(FREQ=-1) D  Q
-        . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!"
-        . S (DUE,DUEDATE)="CNBD"
-        ;
-        S LDATE=$S(RESDATE["X":0,1:+RESDATE)
-        I LDATE=0 S (DUE,DUEDATE)="DUE NOW" Q
-        S DATE=$$FULLDATE(LDATE),DUEDATE=$$NEWDATE(DATE,FREQ)
-        ;
-SETDUE  ;If the due date is less than or equal to today's date the reminder
-        ;is due.
-        S TODAY=$$NOW^PXRMDATE
-        I +DUEDATE'>TODAY S DUE="DUE NOW"  Q
-        ;
-        S DIAT="-"_$P(DEFARR(0),U,4)
-        I DIAT="-" D
-        . S DIATOK=0
-        . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time"
-        E  S DIATOK=1
-        ;
-        S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE)
-        S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED")
-        Q
-        ;
-        ;==================================================
-DURATION(START,STOP)    ;Return the number days between the Start Date and
-        ;Stop Date.
-        I +START=0 Q 0
-        N PXRMNOW
-        S PXRMNOW=$$NOW^PXRMDATE
-        I START>PXRMNOW Q 0
-        I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW
-        Q $$FMDIFF^XLFDT(STOP,START)
-        ;
-        ;==================================================
-EDATE(DATE)     ;Check for an historical (event) date, format as appropriate.
-        Q $$FMTE^XLFDT(DATE,"5DZ")
-        ;
-        ;==================================================
-FULLDATE(DATE)  ;See if DATE is a full date, i.e., it has a month and
-        ;a day along with a year. If the month is missing assume Jan. If the
-        ;day is missing assume the first. Issue a warning so the user knows
-        ;what happened. DATE should be in Fileman format.
-        N DAY,MISSING,MONTH,TDATE,YEAR
-        S TDATE=DATE
-        S MISSING=0
-        S DAY=$E(DATE,6,7)
-        S MONTH=$E(DATE,4,5)
-        S YEAR=$E(DATE,1,3)
-        I +DAY=0 D
-        . S DAY=1
-        . S MISSING=1
-        . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation."
-        I +MONTH=0 D
-        . S MONTH=1
-        . S MISSING=1
-        . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation."
-        I MISSING D
-        . S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY
-        . I DATE["E" S TDATE=TDATE_"E"
-        Q TDATE
-        ;
-        ;==================================================
-FRQINDAY(FREQ)  ;Given a frequency in the form ND, NM, or NY where N is a
-        ;number and D stands for days, M for months, and Y for years return
-        ;the value in days.
-        I FREQ="" Q ""
-        N CODE,LEN,MULT,NUM
-        S LEN=$L(FREQ)
-        S NUM=$E(FREQ,1,LEN-1)
-        S CODE=$E(FREQ,LEN,LEN)
-        S MULT=1.0
-        I CODE="M" S MULT=30.42
-        I CODE="Y" S MULT=365.25
-        Q +(MULT*NUM)
-        ;
-        ;==================================================
-ISVSYMD(DATE)   ;Return true if DATE is a valid symbolic date.
-        N P1,P1OK,P2,P2OK,OP,PAT
-        S DATE=$P(DATE,"@",1)
-        S OP=$S(DATE["+":"+",1:"-")
-        S P1=$P(DATE,OP,1),P1OK=0
-        F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK
-        I PAT=DATE Q 1
-        S P2=$P(DATE,OP,2),P2OK=0
-        F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK
-        Q P1OK&P2OK
-        ;
-        ;==================================================
-NEWDATE(FMDATE,OFFSET)  ;Given a date in VA Fileman format (FMDATE) and an
-        ;offset of the form NY, NM, ND where N is a number and Y stands for
-        ;years, M for months, and D for days return the new date in VA Fileman
-        ;format. 
-        I FMDATE=0 Q 0
-        N LEN,NEWDATE,NUM,UNIT
-        S LEN=$L(OFFSET)
-        S NUM=+$E(OFFSET,1,LEN-1)
-        S UNIT=$E(OFFSET,LEN)
-        I UNIT="D" G DAY
-        I UNIT="M" G MONTH
-        I UNIT="Y" G YEAR
-        ;Unknown unit just return the original date
-        Q FMDATE
-DAY     ;
-        S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM)
-        Q NEWDATE
-MONTH   ;
-        ;Convert the months to days and then add the days using the DAY code.
-        ;Multiply the number of months by the average number of days in a month.
-        N INT,FRAC
-        S NUM=30.42*NUM
-        ;Round the number of days, FMADD^XLFDT has problems with non-integer
-        ;days.
-        S INT=+$P(NUM,".",1)
-        S FRAC=NUM-INT
-        I FRAC<0.5 S NUM=INT
-        E  S NUM=INT+1
-        G DAY
-        Q
-YEAR    ;
-        Q FMDATE+(10000*NUM)
-        ;
-        ;==================================================
-NOW()   ;If the reminder global PXRMDATE is defined return it, otherwise
-        ;return the current date and time.
-        Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT)
-        ;
-        ;==================================================
-SYMDATE(DATE)   ;Convert a symbolic date into a FileMan date.
-        N %DT,OPER,PFSTACK,SYM,TIME,X,Y
-        S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1)
-        S X=$S(DATE="LAD":$G(PXRMLAD),1:"")
-        I X="" D
-        . S OPER="+-"
-        . D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK)
-        I PFSTACK(0)=3 D
-        . S SYM=PFSTACK(1)
-        . S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"")
-        . I SYM="" S Y=-1 Q
-        .;FileMan only handles D, W, or M so convert Y to months.
-        . I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M"
-        . S X=SYM_PFSTACK(3)_PFSTACK(2)
-        I PFSTACK(0)=1 S X=PFSTACK(1)
-        I TIME'="" S X=X_"@"_TIME
-        S %DT="ST"
-        D ^%DT
-        Q Y
-        ;
-        ;==================================================
-VDATE(VIEN)     ;Given a visit ien return the visit date.
-        N DATE
-        I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
-        E  S DATE=0
-        I $L(DATE)=0 S DATE=0
-        ;Check for historical encounter.
-        I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E"
-        Q DATE
-        ;
+PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;==================================================
+CEFD(FDA) ;Called by the Exchange Utility only if the input packed
+ ;reminder was packed under v1.5  Move Effective Date to Beginning Date.
+ N IND
+ S IND=""
+ F  S IND=$O(FDA(811.902,IND)) Q:IND=""  D
+ . I '$D(FDA(811.902,IND,12)) Q
+ .;If the EFFECTIVE PERIOD exists don't do anything.
+ . I $D(FDA(811.902,IND,9)) Q
+ . S FDA(811.902,IND,9)=FDA(811.902,IND,12)
+ . K FDA(811.902,IND,12)
+ Q
+ ;
+ ;==================================================
+COMPARE(X) ;Compare beginning and ending dates, give a warning if
+ ;Ending Date comes before Beginning Date. Called by ADATE xref in
+ ;definitions and terms.
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ N BDT,EDT
+ S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
+ S EDT=X(2)
+ I EDT="" S EDT="T"
+ S EDT=$$CTFMD^PXRMDATE(EDT)
+ ;If EDT does not contain a time set it to the end of the day.
+ I EDT'["." S EDT=EDT_".235959"
+ I EDT<BDT D
+ . S BDT=$S(X(1)'="":X(1),1:"")
+ . S EDT=$S(X(2)'="":X(2),1:"T@2400")
+ . S TEXT="Warning the ending date ("_EDT_") is before the beginning date ("_BDT_")"
+ . D EN^DDIOL(TEXT)
+ Q
+ ;
+ ;==================================================
+COTN(EFP) ;Convert an Effective Period to the new date/time format.
+ ;Possible effective periods are ND, NM, or NY where N is an integer.
+ S EFP=$$UP^XLFSTR(EFP)
+ I (EFP?1N.N1"D")!(EFP?1N.N1"M")!(EFP?1N.N1"Y") D
+ . S NUM=+EFP
+ . S EFP=$S(NUM=0:"T",1:"T-"_EFP)
+ Q EFP
+ ;
+ ;==================================================
+CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
+ ;forms as well as T-NY to a FileMan date. Also understands LAD for
+ ;Last Admission Date.
+ N %DT,X,Y
+ ;Check for a date FileMan understands.
+ S X=DATE,%DT="ST"
+ D ^%DT
+ ;If it is not a FileMan date check for a symbolic date.
+ I Y=-1 S Y=$$SYMDATE(DATE)
+ ;If it is not a date that is understood by SYMDATE return -1
+ I Y=-1 Q -1
+ I $G(PXRMDATE)'="",$$ISVSYMD(DATE) D
+ . N DIFFS
+ . S DIFFS=-$$FMDIFF^XLFDT(DT,PXRMDATE,2)
+ . S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
+ I DATE["LAD" D
+ . I $G(PXRMLAD)="" S Y=0
+ . E  D
+ .. N DIFFS
+ .. S DIFFS=-$$FMDIFF^XLFDT(DT,$G(PXRMLAD),2)
+ .. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
+ Q Y
+ ;
+ ;=================================================
+DCHECK(DATE) ;Trap for special characters before calling CTFMD^PXRMDATE.
+ ;Used in DIR("PRE") for date inputs.
+ I $D(DTOUT) Q DATE
+ I DATE="" Q DATE
+ I DATE["^" Q DATE
+ I DATE["?" Q DATE
+ Q $$CTFMD^PXRMDATE(DATE)
+ ;
+ ;==================================================
+DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL) ;Compute the due date.
+ ;This is the date of the resolution finding + the reminder frequency.
+ ;Subtract the due in advance time to see if the reminder should be
+ ;marked as due soon.
+ ;
+ N DATE,DIAT,DIATOK,LDATE,PXRMITEM,TDDUE,TODAY
+ S PXRMITEM=DEFARR("IEN")
+ ;If the final frequency is 0Y then the reminder is not due.
+ I FREQ="0Y" S DUE=0,DUEDATE="" Q
+ ;
+ S DUEDATE=""
+ ;Check for custom date due.
+ I DEFARR(45)'="" S DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL)
+ I DUEDATE'="",DUEDATE'=-1 G SETDUE
+ ;
+ ;No custom date due, do regular date calculation.
+ I (FREQ="")!(FREQ=-1) D  Q
+ . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!"
+ . S (DUE,DUEDATE)="CNBD"
+ ;
+ S LDATE=$S(RESDATE["X":0,1:+RESDATE)
+ I LDATE=0 S (DUE,DUEDATE)="DUE NOW" Q
+ S DATE=$$FULLDATE(LDATE),DUEDATE=$$NEWDATE(DATE,FREQ)
+ ;
+SETDUE ;If the due date is less than or equal to today's date the reminder
+ ;is due.
+ S TODAY=$$NOW^PXRMDATE
+ I +DUEDATE'>TODAY S DUE="DUE NOW"  Q
+ ;
+ S DIAT="-"_$P(DEFARR(0),U,4)
+ I DIAT="-" D
+ . S DIATOK=0
+ . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time"
+ E  S DIATOK=1
+ ;
+ S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE)
+ S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED")
+ Q
+ ;
+ ;==================================================
+DURATION(START,STOP) ;Return the number days between the Start Date and
+ ;Stop Date.
+ I +START=0 Q 0
+ N PXRMNOW
+ S PXRMNOW=$$NOW^PXRMDATE
+ I START>PXRMNOW Q 0
+ I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW
+ Q $$FMDIFF^XLFDT(STOP,START)
+ ;
+ ;==================================================
+EDATE(DATE) ;Check for an historical (event) date, format as appropriate.
+ Q $$FMTE^XLFDT(DATE,"5DZ")
+ ;
+ ;==================================================
+FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and
+ ;a day along with a year. If the month is missing assume Jan. If the
+ ;day is missing assume the first. Issue a warning so the user knows
+ ;what happened. DATE should be in Fileman format.
+ N DAY,MISSING,MONTH,TDATE,YEAR
+ S TDATE=DATE
+ S MISSING=0
+ S DAY=$E(DATE,6,7)
+ S MONTH=$E(DATE,4,5)
+ S YEAR=$E(DATE,1,3)
+ I +DAY=0 D
+ . S DAY=1
+ . S MISSING=1
+ . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation."
+ I +MONTH=0 D
+ . S MONTH=1
+ . S MISSING=1
+ . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation."
+ I MISSING D
+ . S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY
+ . I DATE["E" S TDATE=TDATE_"E"
+ Q TDATE
+ ;
+ ;==================================================
+FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a
+ ;number and D stands for days, M for months, and Y for years return
+ ;the value in days.
+ I FREQ="" Q ""
+ N CODE,LEN,MULT,NUM
+ S LEN=$L(FREQ)
+ S NUM=$E(FREQ,1,LEN-1)
+ S CODE=$E(FREQ,LEN,LEN)
+ S MULT=1.0
+ I CODE="M" S MULT=30.42
+ I CODE="Y" S MULT=365.25
+ Q +(MULT*NUM)
+ ;
+ ;==================================================
+ISVSYMD(DATE) ;Return true if DATE is a valid symbolic date.
+ N P1,P1OK,P2,P2OK,OP,PAT
+ S DATE=$P(DATE,"@",1)
+ S OP=$S(DATE["+":"+",1:"-")
+ S P1=$P(DATE,OP,1),P1OK=0
+ F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK
+ I PAT=DATE Q 1
+ S P2=$P(DATE,OP,2),P2OK=0
+ F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK
+ Q P1OK&P2OK
+ ;
+ ;==================================================
+NEWDATE(FMDATE,OFFSET) ;Given a date in VA Fileman format (FMDATE) and an
+ ;offset of the form NY, NM, ND where N is a number and Y stands for
+ ;years, M for months, and D for days return the new date in VA Fileman
+ ;format. 
+ I FMDATE=0 Q 0
+ N LEN,NEWDATE,NUM,UNIT
+ S LEN=$L(OFFSET)
+ S NUM=+$E(OFFSET,1,LEN-1)
+ S UNIT=$E(OFFSET,LEN)
+ I UNIT="D" G DAY
+ I UNIT="M" G MONTH
+ I UNIT="Y" G YEAR
+ ;Unknown unit just return the original date
+ Q FMDATE
+DAY ;
+ S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM)
+ Q NEWDATE
+MONTH ;
+ ;Convert the months to days and then add the days using the DAY code.
+ ;Multiply the number of months by the average number of days in a month.
+ N INT,FRAC
+ S NUM=30.42*NUM
+ ;Round the number of days, FMADD^XLFDT has problems with non-integer
+ ;days.
+ S INT=+$P(NUM,".",1)
+ S FRAC=NUM-INT
+ I FRAC<0.5 S NUM=INT
+ E  S NUM=INT+1
+ G DAY
+ Q
+YEAR ;
+ Q FMDATE+(10000*NUM)
+ ;
+ ;==================================================
+NOW() ;If the reminder global PXRMDATE is defined return it, otherwise
+ ;return the current date and time.
+ Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT)
+ ;
+ ;==================================================
+SYMDATE(DATE) ;Convert a symbolic date into a FileMan date.
+ N %DT,OPER,PFSTACK,SYM,TIME,X,Y
+ S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1)
+ S X=$S(DATE="LAD":$G(PXRMLAD),1:"")
+ I X="" D
+ . S OPER="+-"
+ . D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK)
+ I PFSTACK(0)=3 D
+ . S SYM=PFSTACK(1)
+ . S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"")
+ . I SYM="" S Y=-1 Q
+ .;FileMan only handles D, W, or M so convert Y to months.
+ . I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M"
+ . S X=SYM_PFSTACK(3)_PFSTACK(2)
+ I PFSTACK(0)=1 S X=PFSTACK(1)
+ I TIME'="" S X=X_"@"_TIME
+ S %DT="ST"
+ D ^%DT
+ Q Y
+ ;
+ ;==================================================
+VDATE(VIEN) ;Given a visit ien return the visit date.
+ N DATE
+ I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
+ E  S DATE=0
+ I $L(DATE)=0 S DATE=0
+ ;Check for historical encounter.
+ I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E"
+ Q DATE
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m

@@ -1 @@
-PXRMDBL3        ; SLC/PJH - Reminder Dialog Generation. (overflow) ;11/08/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ; Called from PXRMDBL1
-        ;
-        ;Set number range for site
-START   ;
-        D SETSTART^PXRMCOPY("^PXRMD(801.41,")
-        ;Update dialog file for individual dialog items
-        D UPDATE(.ARRAY,.WPTXT,"E")
-        ;Create reminder dialog
-        D UPDATE(.DSET,"","R")
-        ;
-        W !!,"Dialog build complete" H 3
-END     Q
-        ;
-        ;Error Handler
-        ;-------------
-ERR(DESC)       ;
-        N ERROR,IC,REF
-        S ERROR(1)="Unable to update dialog file : "_DESC
-        S ERROR(2)="Error in UPDATE^DIE, needs further investigation"
-        ;Move MSG into ERROR
-        S REF="MSG"
-        F IC=3:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
-        ;Screen message
-        D BMES^XPDUTL(.ERROR)
-        Q
-        ;
-        ;Check if dialog element already exists
-        ;--------------------------------------
-EXISTS(NAME)    ;
-        N IEN S IEN=$O(^PXRMD(801.41,"B",NAME,""))
-        I IEN S DSET(1,CNT*5)=IEN Q 1
-        Q 0
-        ;
-        ;Update edit history
-        ;-------------------
-HIS(IENN)       ;
-        ;First delete any existing history entries.
-        N ENTRY,IND,IENS,FDA,FDAIEN,MSG,WP
-        S ENTRY="^PXRMD(801.41,"_IENN_",110)"
-        S IND=0
-        F  S IND=$O(@ENTRY@(IND)) Q:+IND=0  D
-        . S IENS=IND_","_IENN_","
-        . S FDA(801.44,IENS,.01)="@"
-        I $D(FDA(801.44)) D
-        .D FILE^DIE("K","FDA","MSG") I $D(MSG) D AWRITE^PXRMUTIL("MSG")
-        ;Establish an initial entry in the edit history.
-        K FDA,MSG
-        S IENS="+1,"_IENN_","
-        S FDAIEN(IENN)=IENN
-        S FDA(801.44,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S FDA(801.44,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
-        S FDA(801.44,IENS,2)="WP(1,1)"
-        S WP(1,1,1)="Autogenerated"
-        D UPDATE^DIE("E","FDA","FDAIEN","MSG")
-        I $D(MSG) D AWRITE^PXRMUTIL("MSG")
-        Q
-        ;
-        ;Mental Health
-        ;-------------
-MHOK(IEN)       ;
-        N RNAME,TEST,YT S YT=""
-        ;Convert ien to name
-        ;DBIA #5044
-        S YT("CODE")=$P($G(^YTT(601.71,IEN,0)),U)
-        ;Quit if no code found
-        I YT("CODE")="" Q 0
-        I '$$OK^PXRMDLL(IEN) Q 0
-        ;Check if valid
-        ;I TEST(1)["[ERROR]" Q 0
-        ;
-        S DNAME=FTYP_" "_YT("CODE")
-        ;Create arrays
-        S CNT=CNT+1
-        ;Convert dialog item name to UC
-        S DNAME=$TR(DNAME,LOWER,UPPER)
-        ;Truncate the item name - without finesse
-        S DSHORT=DNAME
-        I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
-        ;Dialog item name, finding item and result 
-        S ARRAY(CNT)=DSHORT_U_U_RESN_U
-        ;Commented out Result Group Patch 6 until a decision can be made
-        ;Result group name
-        ;S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
-        ;Result pointer
-        ;S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
-        ;If aims exclude from p/n
-        I YT("CODE")="AIMS" S $P(ARRAY(CNT),U,6)=1
-        ;Prompt text
-        S WPTXT(CNT,1)=YT("CODE")_" (Mental Health Instrument)"
-        ;test
-        W !!,CNT,?5,WPTXT(CNT,1)
-        Q 1
-        ;
-        ;Sub-routine to update dialog file #801.41
-        ;-----------------------------------------
-UPDATE(INP,WPTXT,DTYPE) ;
-        N CNT,DATA,DESC,IEN,STRING,SUB,TEXT
-        N FDA,FDAIEN,MSG
-        ;Get each dialog line in turn
-        S STRING="Updating "_$S(DTYPE="E":"Dialog Elements",1:"Reminder Dialog")
-        D BMES^XPDUTL(STRING)
-        ;
-        ;Create FDA for each entry in array
-        S CNT=""
-        F  S CNT=$O(INP(CNT)) Q:CNT=""  D  Q:$D(MSG)
-        .;If finding is a finding item parameter no need to build an element
-        .I DTYPE="E",$P(INP(CNT),U)=801.43 D  Q
-        ..S DSET(1,CNT)=$P(INP(CNT),U,2)
-        .;Build FDA array
-        .K FDAIEN,FDA
-        .;If existing element and not in replace mode don't update FDA
-        .I DTYPE="E",'PXRMREPL Q:$$EXISTS($P(INP(CNT),U))
-        .;Name
-        .S FDA(801.41,"?+1,",.01)=$P(INP(CNT),U)
-        .;Dialog type
-        .S FDA(801.41,"?+1,",4)=DTYPE
-        .;Class
-        .S FDA(801.41,"?+1,",100)="L"
-        .;Sponsor
-        .S FDA(801.41,"?+1,",101)=""
-        .;Prompt text/finding entries
-        .I DTYPE="E" D
-        ..S FDA(801.41,"?+1,",13)=$P(INP(CNT),U,2)
-        ..S FDA(801.41,"?+1,",15)=$P(INP(CNT),U,3)
-        ..S FDA(801.41,"?+1,",17)=$P(INP(CNT),U,4)
-        ..S FDA(801.41,"?+1,",25)="WPTXT("_CNT_")"
-        ..;MH fields (exclude from P/N and results pointer)
-        ..S:$P(INP(CNT),U,6) FDA(801.41,"?+1,",54)=$P(INP(CNT),U,6)
-        ..;S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
-        .;Reminder dialog associated reminder/DISABLE
-        .I DTYPE="R" D
-        ..S FDA(801.41,"?+1,",2)=REM
-        ..I PXRMENAB'="Y" S FDA(801.41,"?+1,",3)="DISABLED AT AUTO GENERATE"
-        .;Dialog items point to prompts and actions, Sets point to dialog items
-        .N ACNT,SUB
-        .;S ACNT=0,SUB=2
-        .S ACNT=0,SUB=1
-        .F  S ACNT=$O(INP(CNT,ACNT)) Q:ACNT=""  D
-        ..S SUB=SUB+1,FDA(801.412,"?+"_SUB_",?+1,",.01)=ACNT
-        ..S FDA(801.412,"?+"_SUB_",?+1,",2)=$P(INP(CNT,ACNT),U)
-        ..S FDA(801.412,"?+"_SUB_",?+1,",6)=$P(INP(CNT,ACNT),U,2)
-        ..S FDA(801.412,"?+"_SUB_",?+1,",7)=$P(INP(CNT,ACNT),U,3)
-        ..S FDA(801.412,"?+"_SUB_",?+1,",8)=$P(INP(CNT,ACNT),U,4)
-        ..S FDA(801.412,"?+"_SUB_",?+1,",9)=$P(INP(CNT,ACNT),U,5)
-        .;Update #801.41
-        .D UPDATE^DIE("","FDA","FDAIEN","MSG")
-        .I $D(MSG) D ERR($G(INP(CNT))) Q
-        .;Save IEN of dialog created/used for later use in building dialog set 
-        .I DTYPE="E" S DSET(1,CNT*5)=FDAIEN(1)
-        .;Insert link to reminder
-        .I DTYPE="R",PXRMLINK="Y" D
-        ..S $P(^PXD(811.9,REM,51),U)=FDAIEN(1),^PXD(811.9,"AG",FDAIEN(1),REM)=""
-        .;Update Edit History
-        .D HIS(FDAIEN(1))
-        Q
+PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;04/30/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ; Called from PXRMDBL1
+ ;
+ ;Set number range for site
+START D SETSTART^PXRMCOPY("^PXRMD(801.41,")
+ ;Update dialog file for individual dialog items
+ D UPDATE(.ARRAY,.WPTXT,"E")
+ ;Create reminder dialog
+ D UPDATE(.DSET,"","R")
+ ;
+ W !!,"Dialog build complete" H 3
+END Q
+ ;
+ ;Error Handler
+ ;-------------
+ERR(DESC) ;
+ N ERROR,IC,REF
+ S ERROR(1)="Unable to update dialog file : "_DESC
+ S ERROR(2)="Error in UPDATE^DIE, needs further investigation"
+ ;Move MSG into ERROR
+ S REF="MSG"
+ F IC=3:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
+ ;Screen message
+ D BMES^XPDUTL(.ERROR)
+ Q
+ ;
+ ;Check if dialog element already exists
+ ;--------------------------------------
+EXISTS(NAME) ;
+ N IEN S IEN=$O(^PXRMD(801.41,"B",NAME,""))
+ I IEN S DSET(1,CNT*5)=IEN Q 1
+ Q 0
+ ;
+ ;Update edit history
+ ;-------------------
+HIS(IENN) ;
+ ;First delete any existing history entries.
+ N ENTRY,IND,IENS,FDA,FDAIEN,MSG,WP
+ S ENTRY="^PXRMD(801.41,"_IENN_",110)"
+ S IND=0
+ F  S IND=$O(@ENTRY@(IND)) Q:+IND=0  D
+ . S IENS=IND_","_IENN_","
+ . S FDA(801.44,IENS,.01)="@"
+ I $D(FDA(801.44)) D
+ .D FILE^DIE("K","FDA","MSG") I $D(MSG) D AWRITE^PXRMUTIL("MSG")
+ ;Establish an initial entry in the edit history.
+ K FDA,MSG
+ S IENS="+1,"_IENN_","
+ S FDAIEN(IENN)=IENN
+ S FDA(801.44,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S FDA(801.44,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
+ S FDA(801.44,IENS,2)="WP(1,1)"
+ S WP(1,1,1)="Autogenerated"
+ D UPDATE^DIE("E","FDA","FDAIEN","MSG")
+ I $D(MSG) D AWRITE^PXRMUTIL("MSG")
+ Q
+ ;
+ ;Mental Health
+ ;-------------
+MHOK(IEN) ;
+ N RNAME,TEST,YT S YT=""
+ ;Convert ien to name
+ S YT("CODE")=$P($G(^YTT(601,IEN,0)),U)
+ ;Quit if no code found
+ I YT("CODE")="" Q 0
+ ;Check if this is an allowable GUI test
+ I (YT("CODE")'="GAF"),($P($G(^YTT(601.6,IEN,0)),U,4)'="Y") Q 0
+ ;Get details of test
+ D SHOWALL^YTAPI3(.TEST,.YT)
+ ;Check if valid
+ I TEST(1)["[ERROR]" Q 0
+ ;
+ S DNAME=FTYP_" "_YT("CODE")
+ ;Create arrays
+ S CNT=CNT+1
+ ;Convert dialog item name to UC
+ S DNAME=$TR(DNAME,LOWER,UPPER)
+ ;Truncate the item name - without finesse
+ S DSHORT=DNAME
+ I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
+ ;Dialog item name, finding item and result 
+ S ARRAY(CNT)=DSHORT_U_U_RESN_U
+ ;Result group name
+ S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
+ ;Result pointer
+ S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
+ ;If aims exclude from p/n
+ I YT("CODE")="AIMS" S $P(ARRAY(CNT),U,6)=1
+ ;Prompt text
+ S WPTXT(CNT,1)=YT("CODE")_" (Mental Health Instrument)"
+ ;test
+ W !!,CNT,?5,WPTXT(CNT,1)
+ Q 1
+ ;
+ ;Sub-routine to update dialog file #801.41
+ ;-----------------------------------------
+UPDATE(INP,WPTXT,DTYPE) ;
+ N CNT,DATA,DESC,IEN,STRING,SUB,TEXT
+ N FDA,FDAIEN,MSG
+ ;Get each dialog line in turn
+ S STRING="Updating "_$S(DTYPE="E":"Dialog Elements",1:"Reminder Dialog")
+ D BMES^XPDUTL(STRING)
+ ;
+ ;Create FDA for each entry in array
+ S CNT=""
+ F  S CNT=$O(INP(CNT)) Q:CNT=""  D  Q:$D(MSG)
+ .;If finding is a finding item parameter no need to build an element
+ .I DTYPE="E",$P(INP(CNT),U)=801.43 D  Q
+ ..S DSET(1,CNT)=$P(INP(CNT),U,2)
+ .;Build FDA array
+ .K FDAIEN,FDA
+ .;If existing element and not in replace mode don't update FDA
+ .I DTYPE="E",'PXRMREPL Q:$$EXISTS($P(INP(CNT),U))
+ .;Name
+ .S FDA(801.41,"?+1,",.01)=$P(INP(CNT),U)
+ .;Dialog type
+ .S FDA(801.41,"?+1,",4)=DTYPE
+ .;Class
+ .S FDA(801.41,"?+1,",100)="L"
+ .;Sponsor
+ .S FDA(801.41,"?+1,",101)=""
+ .;Prompt text/finding entries
+ .I DTYPE="E" D
+ ..S FDA(801.41,"?+1,",13)=$P(INP(CNT),U,2)
+ ..S FDA(801.41,"?+1,",15)=$P(INP(CNT),U,3)
+ ..S FDA(801.41,"?+1,",17)=$P(INP(CNT),U,4)
+ ..S FDA(801.41,"?+1,",25)="WPTXT("_CNT_")"
+ ..;MH fields (exclude from P/N and results pointer)
+ ..S:$P(INP(CNT),U,6) FDA(801.41,"?+1,",54)=$P(INP(CNT),U,6)
+ ..S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
+ .;Reminder dialog associated reminder/DISABLE
+ .I DTYPE="R" D
+ ..S FDA(801.41,"?+1,",2)=REM
+ ..I PXRMENAB'="Y" S FDA(801.41,"?+1,",3)="DISABLED AT AUTO GENERATE"
+ .;Dialog items point to prompts and actions, Sets point to dialog items
+ .N ACNT,SUB
+ .;S ACNT=0,SUB=2
+ .S ACNT=0,SUB=1
+ .F  S ACNT=$O(INP(CNT,ACNT)) Q:ACNT=""  D
+ ..S SUB=SUB+1,FDA(801.412,"?+"_SUB_",?+1,",.01)=ACNT
+ ..S FDA(801.412,"?+"_SUB_",?+1,",2)=$P(INP(CNT,ACNT),U)
+ ..S FDA(801.412,"?+"_SUB_",?+1,",6)=$P(INP(CNT,ACNT),U,2)
+ ..S FDA(801.412,"?+"_SUB_",?+1,",7)=$P(INP(CNT,ACNT),U,3)
+ ..S FDA(801.412,"?+"_SUB_",?+1,",8)=$P(INP(CNT,ACNT),U,4)
+ ..S FDA(801.412,"?+"_SUB_",?+1,",9)=$P(INP(CNT,ACNT),U,5)
+ .;Update #801.41
+ .D UPDATE^DIE("","FDA","FDAIEN","MSG")
+ .I $D(MSG) D ERR($G(INP(CNT))) Q
+ .;Save IEN of dialog created/used for later use in building dialog set 
+ .I DTYPE="E" S DSET(1,CNT*5)=FDAIEN(1)
+ .;Insert link to reminder
+ .I DTYPE="R",PXRMLINK="Y" D
+ ..S $P(^PXD(811.9,REM,51),U)=FDAIEN(1),^PXD(811.9,"AG",FDAIEN(1),REM)=""
+ .;Update Edit History
+ .D HIS(FDAIEN(1))
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m

@@ -1 @@
-PXRMDEDT        ; SLC/PJH - Edit PXRM reminder dialog. ;10/18/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD
-        ;
-        ;Add Dialog
-        ;----------
-ADD     N DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,HED
-        S HED="ADD DIALOG"
-        W IORESET
-        F  D  Q:$D(DTOUT)
-        .S DIC="^PXRMD(801.41,"
-        .;Set the starting place for additions.
-        .D SETSTART^PXRMCOPY(DIC)
-        .S DIC(0)="AELMQ",DLAYGO=801.41
-        .S DIC("A")="Select DIALOG to add: "
-        .S DIC("DR")="4///"_$G(PXRMDTYP)
-        .D ^DIC
-        .I $D(DUOUT) S DTOUT=1
-        .I ($D(DTOUT))!($D(DUOUT)) Q
-        .I Y=-1 K DIC S DTOUT=1 Q
-        .I $P(Y,U,3)'=1 W !,"This dialog name already exists" Q
-        .S DA=$P(Y,U,1)
-        .;Determine dialog type
-        .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
-        .;Enter dialog type if a new entry
-        .I DTYP="" D  Q:$D(Y)
-        ..N DIE,DR
-        ..S DIE=801.41,DR=4
-        ..D ^DIE
-        .;
-        .;Edit Dialog
-        .D EDIT(DTYP,DA,0)
-        Q
-        ;
-        ;called by protocol PXRM DIALOG EDIT
-        ;-----------------------------------
-EDIT(TYP,DA,OIEN)       ;
-        Q:'$$LOCK(DA)
-        W IORESET
-        N CS1,CS2,D1,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,DINUSE,TYP,ODA,Y
-        ;Save checksum
-        S VALMBCK=""
-        S CS1=$$FILE^PXRMEXCS(801.41,DA)
-        ;
-        ;Check dialog type
-        S TYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
-        S DIE="^PXRMD(801.41,",DIDEL=801.41,DINUSE=0,ODA=DA
-        ;Reminder Dialog
-        I TYP="R" S DR="[PXRM EDIT REMINDER DIALOG]"
-        ;Dialog Element
-        I TYP="E" S DR="[PXRM EDIT ELEMENT]"
-        ;Additional Prompt
-        ;I TYP="P" S DR="[PXRM EDIT PROMPT]"
-        ;Forced Value
-        I TYP="F" S DR="[PXRM EDIT FORCED VALUE]"
-        ;Dialog Group (Finding item dialog)
-        I TYP="G" S DR="[PXRM EDIT GROUP]" ;S VALMBCK="R"
-        ;Result Group
-        I TYP="S" S DR="[PXRM RESULT GROUP]"
-        ;Result Element
-        I TYP="T" S DR="[PXRM RESULT ELEMENT]"
-        ;Allows limited edit of national dialogs
-        I $P($G(^PXRMD(801.41,DA,100)),U)="N" D
-        .I TYP="T",+$P($G(^PXMRD(801.41,DA,100)),U,4)=0 Q
-        .I $G(PXRMINST)=1,DUZ(0)="@" Q
-        .S DR="[PXRM EDIT NATIONAL DIALOG]",DINUSE=1
-        ;
-        I "GEPF"[TYP D
-        .I '$D(^PXRMD(801.41,"AD",DA)) W !,"Not used by any other dialog",! Q
-        .I PXRMGTYP'="DLG" S DINUSE=1 Q
-        .I PXRMGTYP="DLG" D  Q
-        ..N SUB
-        ..S SUB=0
-        ..F  S SUB=$O(^PXRMD(801.41,"AD",DA,SUB)) Q:'SUB  Q:DINUSE  D
-        ...I SUB'=PXRMDIEN S DINUSE=1
-        I DINUSE D
-        .W !,"Current dialog element/group name: "_$P($G(^PXRMD(801.41,DA,0)),U)
-        .I TYP="S" Q
-        .I PXRMGTYP="DLGE" D
-        ..W !,"Used by:" D USE^PXRMDLST(DA,10,"")
-        ..I $D(^PXRMD(801.41,"R",DA))'>0 Q
-        ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,"")
-        .I PXRMGTYP'="DLGE" D
-        ..W !,"Used by:" D USE^PXRMDLST(DA,10,PXRMDIEN)
-        ..I $D(^PXRMD(801.41,"R",DA))'>0 Q
-        ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,PXRMDIEN)
-        ;
-        ;Save list of components
-        N COMP D COMP^PXRMDEDX(DA,.COMP)
-        ;Edit dialog then unlock
-        I TYP'="P" D ^DIE D UNLOCK(ODA) I $G(DA)="",$G(OIEN)>0 D
-        .S DA=OIEN,DR="118////@" D ^DIE K DA
-        I TYP="P" D PROMPT(DA) D UNLOCK(ODA)
-        I '$D(DUOUT)&($G(D1)'="") D  Q
-        . I $P($G(^PXRMD(801.41,DA,10,D1,0)),U,2)="" D  Q
-        . . S DA(1)=DA,DA=D1 Q:'DA
-        . . S DIK="^PXRMD(801.41,"_DA(1)_",10,"
-        . . D ^DIK
-        . . S VALMBG=1
-        I '$D(DA) D  Q
-        .;Clear any pointers from #811.9
-        .I $D(PXRMDIEN) D PURGE(PXRMDIEN)
-        .;Option to delete components
-        .I $D(COMP) D DELETE^PXRMDEDX(.COMP)
-        .S VALMBCK="R"
-        ;
-        ;Update edit history
-        I (TYP'="R") D
-        .S CS2=$$FILE^PXRMEXCS(801.41,DA) Q:CS2=CS1  Q:+CS2=0
-        .S DIC="^PXRMD(801.41,"
-        .D SEHIST^PXRMUTIL(801.41,DIC,DA)
-        ;
-        ;Redisplay changes (reminder dialog option only)
-        I PXRMGTYP="DLG",TYP="R" D
-        .;Get name of reminder dialog again
-        .S Y=$P($G(^PXRMD(801.41,DA,0)),U)
-        .;Format headings to include dialog name
-        .S PXRMHD="REMINDER DIALOG NAME: "_$P(Y,U)
-        .;Check if the set is disable and add to header if disabled
-        .I $P(^PXRMD(801.41,DA,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
-        .;Reset header in case name has changed
-        .S VALMHDR(1)=PXRMHD
-        Q
-        ;
-        ;Add SINGLE dialog element (protocol PXRM DIALOG SELECTION ITEM)
-        ;-------------------------
-ESEL(PXRMDIEN,SEL)      ;
-        N DA,DIC,DLAYGO,DNEW,DTOUT,DUOUT,DTYP,Y
-        ;
-        S DIC="^PXRMD(801.41,"
-        S DLAYGO="801.41"
-        ;Set the starting place for additions.
-        D SETSTART^PXRMCOPY(DIC)
-        S DIC(0)="AEMQL"
-        S DIC("A")="Select new DIALOG ELEMENT: "
-        S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
-        S DIC("DR")="4///E"
-        W !
-        D ^DIC
-        I $D(DUOUT) S DTOUT=1
-        I ($D(DTOUT))!($D(DUOUT)) Q
-        I Y=-1 K DIC S DTOUT=1 Q
-        S DA=$P(Y,U,1) Q:'DA
-        S DNEW=$P(Y,U,3)
-        ;Group points to itself
-        I 'DNEW,$$VGROUP(DA,PXRMDIEN) Q
-        ;Add to dialog
-        D EADD(SEL,DA,PXRMDIEN)
-        ;Determine dialog type
-        S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
-        ;
-        ;Edit Dialog
-        I DNEW D EDIT(DTYP,DA)
-        Q
-        ;
-        ;Update dialog component multiple
-        ;--------------------------------
-EADD(SEL,NSUB,PXRMDIEN) ;
-        N DA,DATA,NEXT
-        S DATA=$G(^PXRMD(801.41,PXRMDIEN,10,0)),NEXT=$P(DATA,U,3)+1
-        I DATA="" S DATA="^801.412IA"
-        S DA=NSUB,DA(1)=PXRMDIEN
-        S ^PXRMD(801.41,PXRMDIEN,10,NEXT,0)=SEL_U_DA_"^^^^^^^"
-        ;Update next slot
-        S $P(DATA,U,4)=$P(DATA,U,4)+1,$P(DATA,U,3)=NEXT
-        S ^PXRMD(801.41,PXRMDIEN,10,0)=DATA
-        ;Re-index
-        N DIK,DA S DIK="^PXRMD(801.41,",DA=PXRMDIEN
-        D IX^DIK
-        Q
-        ;
-        ;Change Dialog Element Type
-        ;--------------------------
-NTYP(TYP)       ;
-        N X,Y,DIR K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="SA"_U_"E:Element;"
-        S DIR(0)=DIR(0)_"G:Group;"
-        S DIR("A")="Dialog Element Type: "
-        S DIR("B")="E"
-        S DIR("?")="Select from the codes displayed. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMDEDT(3)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        S TYP=Y
-        Q
-        ;
-        ;Clear pointers from the reminder file and process ID file
-        ;---------------------------------------------------------
-PURGE(DIEN)     ;
-        ;Purge pointers to this dialog from reminder file
-        N RIEN
-        S RIEN=0
-        F  S RIEN=$O(^PXD(811.9,"AG",DIEN,RIEN)) Q:'RIEN  D
-        .K ^PXD(811.9,RIEN,51),^PXD(811.9,"AG",DIEN,RIEN)
-        ;
-        Q
-        ;
-VGROUP(DA,IEN)  ;Check dialog index to see if group will point to itself 
-        N FOUND
-        S FOUND=0
-        ;
-        ;Only do check if dialog is a group
-        I $P($G(^PXRMD(801.41,DA,0)),U,4)'="G" Q FOUND
-        ;
-        ;Group cannot be added to itself
-        I DA=IEN D  Q FOUND
-        .S FOUND=1
-        .W !,"A group cannot be added to itself" H 2
-        ;
-        ;IEN is the dialog group being added to 
-        D VGROUP1(DA,IEN)
-        Q FOUND
-        ;
-VGROUP1(DA,DIEN)        ;Examine all parent dialogs
-        ;
-        ;End search if already found
-        Q:FOUND
-        ;
-        ;Check if dialog being added is a parent at this level
-        I $D(^PXRMD(801.41,"AD",DIEN,DA)) D  Q
-        .S FOUND=1
-        .W !,"A group cannot be added as it's own descendant" H 2
-        ;
-        ;If not look at other parents
-        N SUB
-        S SUB=0
-        F  S SUB=$O(^PXRMD(801.41,"AD",DIEN,SUB)) Q:'SUB  D  Q:FOUND
-        .;Ignore reminder dialogs
-        .I $P($G(^PXRMD(801.41,SUB,0)),U,4)'="G" Q
-        .;Repeat check on other parents
-        .D VGROUP1(DA,SUB)
-        Q
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        N DIWF,DIWL,DIWR,IC
-        S DIWF="C70",DIWL=0,DIWR=70
-        ;
-        I CALL=1 D
-        .S HTEXT(1)="Select E to edit dialog element. If you wish to create"
-        .S HTEXT(2)="a new dialog element just for this reminder dialog select"
-        .S HTEXT(3)="C to copy and replace the current element. Select D to"
-        .S HTEXT(4)="delete the sequence number/element from the dialog."
-        I CALL=2 D
-        .S HTEXT(1)="Enter Y to copy the current dialog element to a new name"
-        .S HTEXT(2)="and then use this new element in the reminder dialog."
-        I CALL=3 D
-        .S HTEXT(1)="Enter G to change the current dialog element into a dialog"
-        .S HTEXT(2)="group so that additional elements can be added. Enter E to"
-        .S HTEXT(3)="leave the type of the dialog element unchanged."
-        I CALL=4 D
-        .S HTEXT(1)="Enter Y to change the dialog prompt created into a forced"
-        .S HTEXT(2)="value. To edit the new forced value switch to the forced"
-        .S HTEXT(3)="value screen using CV. This option only applies to prompts"
-        .S HTEXT(4)="which update PCE or vitals."
-        .S HTEXT(5)="Enter N to leave the dialog prompt unchanged."
-        K ^UTILITY($J,"W")
-        S IC=""
-        F  S IC=$O(HTEXT(IC)) Q:IC=""  D
-        . S X=HTEXT(IC)
-        . D ^DIWP
-        W !
-        S IC=0
-        F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
-        . W !,^UTILITY($J,"W",0,IC,0)
-        K ^UTILITY($J,"W")
-        W !
-        Q
-        ;
-LOCK(DA)        ;Lock the record
-        N OK
-        S OK=1
-        I '$$VEDIT^PXRMUTIL("^PXRMD(801.41,",DA) D
-        .N DTYP
-        .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
-        .;Allow limit edit of Result Elements that are not lock
-        .I DTYP="T",+$P($G(^PXRMD(801.41,DA,100)),U,4)=0 Q
-        .;Allow edit of findings but not component multiple on groups 
-        .I DTYP="G",$G(PXRMDIEN),DA'=PXRMDIEN Q
-        .I DTYP="G",$G(PXRMGTYP)="DLGE" Q
-        .;Allow edit of element findings
-        .I DTYP="E" Q
-        .S OK=0
-        .W !!,?5,"VA- and national class reminder dialogs may not be edited" H 2
-        I 'OK Q 0
-        ;
-        L +^PXRMD(801.41,DA):0 I  Q 1
-        E  W !!,?5,"Another user is editing this file, try later" H 2 Q 0
-        ;
-PROMPT(IEN)     ;
-        N DIE,DR
-        S DIE="^PXRMD(801.41,",DA=IEN
-        S DR=".01;3;100;101;102;24;23;21"
-        S IEN=$G(^PXRMD(801.41,IEN,46)) I $G(IEN)="" G EX
-        I $P($G(^PXRMD(801.42,IEN,0)),U)="COM" S DR=DR_";45"
-EX      ;
-        D ^DIE
-        Q
-        ;
-UNLOCK(DA)      ;Unlock the record
-        L -^PXRMD(801.41,DA)
-        Q
+PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;07/28/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD
+ ;
+ ;Add Dialog
+ ;----------
+ADD N DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,HED
+ S HED="ADD DIALOG"
+ W IORESET
+ F  D  Q:$D(DTOUT)
+ .S DIC="^PXRMD(801.41,"
+ .;Set the starting place for additions.
+ .D SETSTART^PXRMCOPY(DIC)
+ .S DIC(0)="AELMQ",DLAYGO=801.41
+ .S DIC("A")="Select DIALOG to add: "
+ .S DIC("DR")="4///"_$G(PXRMDTYP)
+ .D ^DIC
+ .I $D(DUOUT) S DTOUT=1
+ .I ($D(DTOUT))!($D(DUOUT)) Q
+ .I Y=-1 K DIC S DTOUT=1 Q
+ .I $P(Y,U,3)'=1 W !,"This dialog name already exists" Q
+ .S DA=$P(Y,U,1)
+ .;Determine dialog type
+ .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
+ .;Enter dialog type if a new entry
+ .I DTYP="" D  Q:$D(Y)
+ ..N DIE,DR
+ ..S DIE=801.41,DR=4
+ ..D ^DIE
+ .;
+ .;Edit Dialog
+ .D EDIT(DTYP,DA,0)
+ Q
+ ;
+ ;called by protocol PXRM DIALOG EDIT
+ ;-----------------------------------
+EDIT(TYP,DA,OIEN) ;
+ Q:'$$LOCK(DA)
+ W IORESET
+ N CS1,CS2,D1,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,DINUSE,TYP,ODA,Y
+ ;Save checksum
+ S VALMBCK=""
+ S CS1=$$FILE^PXRMEXCS(801.41,DA)
+ ;
+ ;Check dialog type
+ S TYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
+ S DIE="^PXRMD(801.41,",DIDEL=801.41,DINUSE=0,ODA=DA
+ ;Reminder Dialog
+ I TYP="R" S DR="[PXRM EDIT REMINDER DIALOG]"
+ ;Dialog Element
+ I TYP="E" S DR="[PXRM EDIT ELEMENT]"
+ ;Additional Prompt
+ ;I TYP="P" S DR="[PXRM EDIT PROMPT]"
+ ;Forced Value
+ I TYP="F" S DR="[PXRM EDIT FORCED VALUE]"
+ ;Dialog Group (Finding item dialog)
+ I TYP="G" S DR="[PXRM EDIT GROUP]" ;S VALMBCK="R"
+ ;Result Group
+ I TYP="S" S DR="[PXRM RESULT GROUP]"
+ ;Result Element
+ I TYP="T" S DR="[PXRM RESULT ELEMENT]"
+ ;Allows limited edit of national dialogs
+ I $P($G(^PXRMD(801.41,DA,100)),U)="N" D
+ .I $G(PXRMINST)=1,DUZ(0)="@" Q
+ .S DR="[PXRM EDIT NATIONAL DIALOG]",DINUSE=1
+ ;
+ I "GEPF"[TYP D
+ .I '$D(^PXRMD(801.41,"AD",DA)) W !,"Not used by any other dialog",! Q
+ .I PXRMGTYP'="DLG" S DINUSE=1 Q
+ .I PXRMGTYP="DLG" D  Q
+ ..N SUB
+ ..S SUB=0
+ ..F  S SUB=$O(^PXRMD(801.41,"AD",DA,SUB)) Q:'SUB  Q:DINUSE  D
+ ...I SUB'=PXRMDIEN S DINUSE=1
+ I DINUSE D
+ .W !,"Current dialog element/group name: "_$P($G(^PXRMD(801.41,DA,0)),U)
+ .I TYP="S" Q
+ .I PXRMGTYP="DLGE" D
+ ..W !,"Used by:" D USE^PXRMDLST(DA,10,"")
+ ..I $D(^PXRMD(801.41,"R",DA))'>0 Q
+ ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,"")
+ .I PXRMGTYP'="DLGE" D
+ ..W !,"Used by:" D USE^PXRMDLST(DA,10,PXRMDIEN)
+ ..I $D(^PXRMD(801.41,"R",DA))'>0 Q
+ ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,PXRMDIEN)
+ ;
+ ;Save list of components
+ N COMP D COMP^PXRMDEDX(DA,.COMP)
+ ;Edit dialog then unlock
+ I TYP'="P" D ^DIE D UNLOCK(ODA) I $G(DA)="",$G(OIEN)>0 D
+ .S DA=OIEN,DR="118////@" D ^DIE K DA
+ I TYP="P" D PROMPT(DA) D UNLOCK(ODA)
+ I '$D(DUOUT)&($G(D1)'="") D  Q
+ . I $P($G(^PXRMD(801.41,DA,10,D1,0)),U,2)="" D  Q
+ . . S DA(1)=DA,DA=D1 Q:'DA
+ . . S DIK="^PXRMD(801.41,"_DA(1)_",10,"
+ . . D ^DIK
+ . . S VALMBG=1
+ I '$D(DA) D  Q
+ .;Clear any pointers from #811.9
+ .I $D(PXRMDIEN) D PURGE(PXRMDIEN)
+ .;Option to delete components
+ .I $D(COMP) D DELETE^PXRMDEDX(.COMP)
+ .S VALMBCK="R"
+ ;
+ ;Update edit history
+ I (TYP'="R") D
+ .S CS2=$$FILE^PXRMEXCS(801.41,DA) Q:CS2=CS1  Q:+CS2=0
+ .S DIC="^PXRMD(801.41,"
+ .D SEHIST^PXRMUTIL(801.41,DIC,DA)
+ ;
+ ;Redisplay changes (reminder dialog option only)
+ I PXRMGTYP="DLG",TYP="R" D
+ .;Get name of reminder dialog again
+ .S Y=$P($G(^PXRMD(801.41,DA,0)),U)
+ .;Format headings to include dialog name
+ .S PXRMHD="REMINDER DIALOG NAME: "_$P(Y,U)
+ .;Check if the set is disable and add to header if disabled
+ .I $P(^PXRMD(801.41,DA,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
+ .;Reset header in case name has changed
+ .S VALMHDR(1)=PXRMHD
+ Q
+ ;
+ ;Add SINGLE dialog element (protocol PXRM DIALOG SELECTION ITEM)
+ ;-------------------------
+ESEL(PXRMDIEN,SEL) ;
+ N DA,DIC,DLAYGO,DNEW,DTOUT,DUOUT,DTYP,Y
+ ;
+ S DIC="^PXRMD(801.41,"
+ S DLAYGO="801.41"
+ ;Set the starting place for additions.
+ D SETSTART^PXRMCOPY(DIC)
+ S DIC(0)="AEMQL"
+ S DIC("A")="Select new DIALOG ELEMENT: "
+ S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
+ S DIC("DR")="4///E"
+ W !
+ D ^DIC
+ I $D(DUOUT) S DTOUT=1
+ I ($D(DTOUT))!($D(DUOUT)) Q
+ I Y=-1 K DIC S DTOUT=1 Q
+ S DA=$P(Y,U,1) Q:'DA
+ S DNEW=$P(Y,U,3)
+ ;Group points to itself
+ I 'DNEW,$$VGROUP(DA,PXRMDIEN) Q
+ ;Add to dialog
+ D EADD(SEL,DA,PXRMDIEN)
+ ;Determine dialog type
+ S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
+ ;
+ ;Edit Dialog
+ I DNEW D EDIT(DTYP,DA)
+ Q
+ ;
+ ;Update dialog component multiple
+ ;--------------------------------
+EADD(SEL,NSUB,PXRMDIEN) ;
+ N DA,DATA,NEXT
+ S DATA=$G(^PXRMD(801.41,PXRMDIEN,10,0)),NEXT=$P(DATA,U,3)+1
+ I DATA="" S DATA="^801.412IA"
+ S DA=NSUB,DA(1)=PXRMDIEN
+ S ^PXRMD(801.41,PXRMDIEN,10,NEXT,0)=SEL_U_DA_"^^^^^^^"
+ ;Update next slot
+ S $P(DATA,U,4)=$P(DATA,U,4)+1,$P(DATA,U,3)=NEXT
+ S ^PXRMD(801.41,PXRMDIEN,10,0)=DATA
+ ;Re-index
+ N DIK,DA S DIK="^PXRMD(801.41,",DA=PXRMDIEN
+ D IX^DIK
+ Q
+ ;
+ ;Change Dialog Element Type
+ ;--------------------------
+NTYP(TYP) ;
+ N X,Y,DIR K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="SA"_U_"E:Element;"
+ S DIR(0)=DIR(0)_"G:Group;"
+ S DIR("A")="Dialog Element Type: "
+ S DIR("B")="E"
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMDEDT(3)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ S TYP=Y
+ Q
+ ;
+ ;Clear pointers from the reminder file and process ID file
+ ;---------------------------------------------------------
+PURGE(DIEN) ;
+ ;Purge pointers to this dialog from reminder file
+ N RIEN
+ S RIEN=0
+ F  S RIEN=$O(^PXD(811.9,"AG",DIEN,RIEN)) Q:'RIEN  D
+ .K ^PXD(811.9,RIEN,51),^PXD(811.9,"AG",DIEN,RIEN)
+ ;
+ Q
+ ;
+VGROUP(DA,IEN) ;Check dialog index to see if group will point to itself 
+ N FOUND
+ S FOUND=0
+ ;
+ ;Only do check if dialog is a group
+ I $P($G(^PXRMD(801.41,DA,0)),U,4)'="G" Q FOUND
+ ;
+ ;Group cannot be added to itself
+ I DA=IEN D  Q FOUND
+ .S FOUND=1
+ .W !,"A group cannot be added to itself" H 2
+ ;
+ ;IEN is the dialog group being added to 
+ D VGROUP1(DA,IEN)
+ Q FOUND
+ ;
+VGROUP1(DA,DIEN) ;Examine all parent dialogs
+ ;
+ ;End search if already found
+ Q:FOUND
+ ;
+ ;Check if dialog being added is a parent at this level
+ I $D(^PXRMD(801.41,"AD",DIEN,DA)) D  Q
+ .S FOUND=1
+ .W !,"A group cannot be added as it's own descendant" H 2
+ ;
+ ;If not look at other parents
+ N SUB
+ S SUB=0
+ F  S SUB=$O(^PXRMD(801.41,"AD",DIEN,SUB)) Q:'SUB  D  Q:FOUND
+ .;Ignore reminder dialogs
+ .I $P($G(^PXRMD(801.41,SUB,0)),U,4)'="G" Q
+ .;Repeat check on other parents
+ .D VGROUP1(DA,SUB)
+ Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ N DIWF,DIWL,DIWR,IC
+ S DIWF="C70",DIWL=0,DIWR=70
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="Select E to edit dialog element. If you wish to create"
+ .S HTEXT(2)="a new dialog element just for this reminder dialog select"
+ .S HTEXT(3)="C to copy and replace the current element. Select D to"
+ .S HTEXT(4)="delete the sequence number/element from the dialog."
+ I CALL=2 D
+ .S HTEXT(1)="Enter Y to copy the current dialog element to a new name"
+ .S HTEXT(2)="and then use this new element in the reminder dialog."
+ I CALL=3 D
+ .S HTEXT(1)="Enter G to change the current dialog element into a dialog"
+ .S HTEXT(2)="group so that additional elements can be added. Enter E to"
+ .S HTEXT(3)="leave the type of the dialog element unchanged."
+ I CALL=4 D
+ .S HTEXT(1)="Enter Y to change the dialog prompt created into a forced"
+ .S HTEXT(2)="value. To edit the new forced value switch to the forced"
+ .S HTEXT(3)="value screen using CV. This option only applies to prompts"
+ .S HTEXT(4)="which update PCE or vitals."
+ .S HTEXT(5)="Enter N to leave the dialog prompt unchanged."
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
+ W !
+ Q
+ ;
+LOCK(DA) ;Lock the record
+ N OK
+ S OK=1
+ I '$$VEDIT^PXRMUTIL("^PXRMD(801.41,",DA) D
+ .N DTYP
+ .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
+ .;Allow edit of findings but not component multiple on groups 
+ .I DTYP="G",$G(PXRMDIEN),DA'=PXRMDIEN Q
+ .I DTYP="G",$G(PXRMGTYP)="DLGE" Q
+ .;Allow edit of element findings
+ .I DTYP="E" Q
+ .S OK=0
+ .W !!,?5,"VA- and national class reminder dialogs may not be edited" H 2
+ I 'OK Q 0
+ ;
+ L +^PXRMD(801.41,DA):0 I  Q 1
+ E  W !!,?5,"Another user is editing this file, try later" H 2 Q 0
+ ;
+PROMPT(IEN) ;
+ N DIE,DR
+ S DIE="^PXRMD(801.41,",DA=IEN
+ S DR=".01;3;100;101;102;24;23;21"
+ S IEN=$G(^PXRMD(801.41,IEN,46)) I $G(IEN)="" G EX
+ I $P($G(^PXRMD(801.42,IEN,0)),U)="COM" S DR=DR_";45"
+EX ;
+ D ^DIE
+ Q
+ ;
+UNLOCK(DA) ;Unlock the record
+ L -^PXRMD(801.41,DA)
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m

@@ -1 @@
-PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;01/24/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;==================================================
-CMOUT   ;Do formatted Clinical Maintenance output.
-        N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
-        W !!,"Formatted Output:"
-        S RIEN=$O(^TMP("PXRHM",$J,""))
-        S RNAME=$O(^TMP("PXRHM",$J,RIEN,""))
-        S TEMP=$G(^TMP("PXRHM",$J,RIEN,RNAME))
-        S STATUS=$P(TEMP,U,1)
-        S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
-        S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
-        S STATCOL=41-($L(STATUS)/2)
-        S DUECOL=53-($L(DUE)/2)
-        S LASTCOL=67-($L(LAST)/2)
-        W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
-        W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
-        S LNUM=0
-        F  S LNUM=$O(^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)) Q:LNUM=""  D
-        . W !,^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)
-        Q
-        ;
-        ;==================================================
-DEB     ;Prompt for patient and reminder by name input component.
-        N DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,X,Y
-        S DIC=2,DIC("A")="Select Patient: "
-        S DIC(0)="AEQMZ"
-        D ^DIC
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DFN=+$P(Y,U,1)
-        I DFN=-1 W !,"No patient selected!" Q
-        S DIC=811.9,DIC("A")="Select Reminder: "
-        D ^DIC
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S PXRMITEM=+$P(Y,U,1)
-        I PXRMITEM=-1 W !,"No reminder selected!" Q
-        S DIR(0)="LA"_U_"0"
-        S DIR("A")="Enter component number 0, 1, 5, 10, 11, 12: "
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        I X="" S X=5
-        S PXRHM=X
-        S DIR(0)="DA^"_0_"::ETX"
-        S DIR("A")="Enter date for reminder evaluation: "
-        S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
-        S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATE=Y
-        I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
-        D DOREM(DFN,PXRMITEM,PXRHM,DATE)
-        Q
-        ;
-        ;==================================================
-DEV     ;Prompt for patient and reminder by name and evaluation date.
-        N DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,REF,X,Y
-        S DIC=2,DIC("A")="Select Patient: "
-        S DIC(0)="AEQMZ"
-        D ^DIC
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DFN=+$P(Y,U,1)
-        S DIC=811.9,DIC("A")="Select Reminder: "
-        D ^DIC
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S PXRMITEM=+$P(Y,U,1)
-        S PXRHM=5
-        S DIR(0)="DA^"_0_"::ETX"
-        S DIR("A")="Enter date for reminder evaluation: "
-        S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
-        S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATE=Y
-        I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
-        D DOREM(DFN,PXRMITEM,PXRHM,DATE)
-        Q
-        ;
-        ;==================================================
-DOREM(DFN,PXRMITEM,PXRMHM,DATE) ;Do the reminder
-        N DEFARR,FIEVAL,FINDING,PXRMDEBG,PXRMID,REF,TFIEVAL
-        ;This is a debugging run so set PXRMDEBG.
-        S PXRMDEBG=1
-        D DEF^PXRMLDR(PXRMITEM,.DEFARR)
-        I +$G(DATE)=0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL)
-        I +$G(DATE)>0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE)
-        ;
-        W !!,"The elements of the FIEVAL array are:"
-        S REF="FIEVAL"
-        D AWRITE^PXRMUTIL(REF)
-        ;
-        I $G(PXRMTDEB) D
-        . W !!,"Term findings:"
-        . S REF="TFIEVAL"
-        . S FINDING=0
-        . F  S FINDING=$O(^TMP("PXRMTDEB",$J,FINDING)) Q:FINDING=""  D
-        .. K TFIEVAL M TFIEVAL(FINDING)=^TMP("PXRMTDEB",$J,FINDING)
-        .. W !,"Finding ",FINDING,":"
-        .. D AWRITE^PXRMUTIL(REF)
-        . K ^TMP("PXRMTDEB",$J)
-        ;
-        W !!,"The elements of the ^TMP(PXRMID,$J) array are:"
-        I $D(PXRMID) S REF="^TMP(PXRMID,$J)" D AWRITE^PXRMUTIL(REF) K ^TMP(PXRMID,$J)
-        ;
-        W !!,"The elements of the ^TMP(""PXRHM"",$J) array are:"
-        S REF="^TMP(""PXRHM"",$J)"
-        D AWRITE^PXRMUTIL(REF)
-        ;
-        I $D(^TMP("PXRHM",$J)) D CMOUT
-        I PXRHM=12 D MHVCOUT
-        K ^TMP("PXRM",$J),^TMP("PXRHM",$J),^TMP("PXRMMHVC",$J)
-        Q
-        ;==================================================
-MHVCOUT ;Do formatted MHV combined output.
-        N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
-        W !!,"Formatted Output:"
-        S RIEN=$O(^TMP("PXRMMHVC",$J,""))
-        S TEMP=^TMP("PXRMMHVC",$J,RIEN,"STATUS")
-        S STATUS=$P(TEMP,U,1)
-        S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
-        S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
-        S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
-        S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
-        S STATCOL=41-($L(STATUS)/2)
-        S DUECOL=53-($L(DUE)/2)
-        S LASTCOL=67-($L(LAST)/2)
-        S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
-        I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
-        W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
-        W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
-        W !!,"---------- Detailed Output ----------"
-        S LNUM=0
-        F  S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)) Q:LNUM=""  D
-        . W !,^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)
-        W !!,"---------- Summary Output ----------"
-        S LNUM=0
-        F  S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)) Q:LNUM=""  D
-        . W !,^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)
-        Q
-        ;
+PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;05/04/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;==================================================
+CMOUT ;Do formatted Clinical Maintenance output.
+ N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
+ W !!,"Formatted Output:"
+ S RIEN=$O(^TMP("PXRHM",$J,""))
+ S RNAME=$O(^TMP("PXRHM",$J,RIEN,""))
+ S TEMP=$G(^TMP("PXRHM",$J,RIEN,RNAME))
+ S STATUS=$P(TEMP,U,1)
+ S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
+ S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
+ S STATCOL=41-($L(STATUS)/2)
+ S DUECOL=53-($L(DUE)/2)
+ S LASTCOL=67-($L(LAST)/2)
+ W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
+ W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
+ S LNUM=0
+ F  S LNUM=$O(^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)) Q:LNUM=""  D
+ . W !,^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)
+ Q
+ ;
+ ;==================================================
+DEB ;Prompt for patient and reminder by name input component.
+ N DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,X,Y
+ S DIC=2,DIC("A")="Select Patient: "
+ S DIC(0)="AEQMZ"
+ D ^DIC
+ I $D(DTOUT)!$D(DUOUT) Q
+ S DFN=+$P(Y,U,1)
+ I DFN=-1 W !,"No patient selected!" Q
+ S DIC=811.9,DIC("A")="Select Reminder: "
+ S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
+ D ^DIC
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S PXRMITEM=+$P(Y,U,1)
+ I PXRMITEM=-1 W !,"No reminder selected!" Q
+ S DIR(0)="LA"_U_"0"
+ S DIR("A")="Enter component number 0, 1, 5, 10, 11, 12: "
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ I X="" S X=5
+ S PXRHM=X
+ S DIR(0)="DA^"_0_"::ETX"
+ S DIR("A")="Enter date for reminder evaluation: "
+ S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
+ S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S DATE=Y
+ I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
+ D DOREM(DFN,PXRMITEM,PXRHM,DATE)
+ Q
+ ;
+ ;==================================================
+DEV ;Prompt for patient and reminder by name and evaluation date.
+ N DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,REF,X,Y
+ S DIC=2,DIC("A")="Select Patient: "
+ S DIC(0)="AEQMZ"
+ D ^DIC
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S DFN=+$P(Y,U,1)
+ S DIC=811.9,DIC("A")="Select Reminder: "
+ S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
+ D ^DIC
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S PXRMITEM=+$P(Y,U,1)
+ S PXRHM=5
+ S DIR(0)="DA^"_0_"::ETX"
+ S DIR("A")="Enter date for reminder evaluation: "
+ S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
+ S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S DATE=Y
+ I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
+ D DOREM(DFN,PXRMITEM,PXRHM,DATE)
+ Q
+ ;
+ ;==================================================
+DOREM(DFN,PXRMITEM,PXRMHM,DATE) ;Do the reminder
+ N DEFARR,FIEVAL,FINDING,PXRMDEBG,PXRMID,REF,TFIEVAL
+ ;This is a debugging run so set PXRMDEBG.
+ S PXRMDEBG=1
+ D DEF^PXRMLDR(PXRMITEM,.DEFARR)
+ I +$G(DATE)=0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL)
+ I +$G(DATE)>0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE)
+ ;
+ W !!,"The elements of the FIEVAL array are:"
+ S REF="FIEVAL"
+ D AWRITE^PXRMUTIL(REF)
+ ;
+ I $G(PXRMTDEB) D
+ . W !!,"Term findings:"
+ . S REF="TFIEVAL"
+ . S FINDING=0
+ . F  S FINDING=$O(^TMP("PXRMTDEB",$J,FINDING)) Q:FINDING=""  D
+ .. K TFIEVAL M TFIEVAL(FINDING)=^TMP("PXRMTDEB",$J,FINDING)
+ .. W !,"Finding ",FINDING,":"
+ .. D AWRITE^PXRMUTIL(REF)
+ . K ^TMP("PXRMTDEB",$J)
+ ;
+ W !!,"The elements of the ^TMP(PXRMID,$J) array are:"
+ I $D(PXRMID) S REF="^TMP(PXRMID,$J)" D AWRITE^PXRMUTIL(REF) K ^TMP(PXRMID,$J)
+ ;
+ W !!,"The elements of the ^TMP(""PXRHM"",$J) array are:"
+ S REF="^TMP(""PXRHM"",$J)"
+ D AWRITE^PXRMUTIL(REF)
+ ;
+ I $D(^TMP("PXRHM",$J)) D CMOUT
+ I PXRHM=12 D MHVCOUT
+ K ^TMP("PXRM",$J),^TMP("PXRHM",$J),^TMP("PXRMMHVC",$J)
+ Q
+ ;==================================================
+MHVCOUT ;Do formatted MHV combined output.
+ N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE
+ W !!,"Formatted Output:"
+ S RIEN=$O(^TMP("PXRMMHVC",$J,""))
+ S TEMP=^TMP("PXRMMHVC",$J,RIEN,"STATUS")
+ S STATUS=$P(TEMP,U,1)
+ S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
+ S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
+ S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2))
+ S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3))
+ S STATCOL=41-($L(STATUS)/2)
+ S DUECOL=53-($L(DUE)/2)
+ S LASTCOL=67-($L(LAST)/2)
+ S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
+ I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
+ W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",!
+ W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,!
+ W !!,"---------- Detailed Output ----------"
+ S LNUM=0
+ F  S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)) Q:LNUM=""  D
+ . W !,^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)
+ W !!,"---------- Summary Output ----------"
+ S LNUM=0
+ F  S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)) Q:LNUM=""  D
+ . W !,^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m

@@ -1 @@
-PXRMDLG4        ; SLC/PJH - Reminder Dialog Edit/Inquiry ;06/05/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-WP(SUB,SUB1,WIDTH,SEQ,VALMCNT)  ;Format WP text
-        N DIWF,DIWL,DIWR,IC,TEXT,X,TXTCNT,DTXT,CNT,SUB2
-        S (CNT,SUB2,TXTCNT)=0
-        F  S SUB2=$O(^PXRMD(801.41,SUB,SUB1,SUB2)) Q:'SUB2  D
-        .S TXTCNT=TXTCNT+1,DTXT(TXTCNT)=$G(^PXRMD(801.41,SUB,SUB1,SUB2,0))
-        .S DTXT(TXTCNT)=$$STRREP^PXRMUTIL($G(DTXT(TXTCNT)),"<br>","\\")
-        I TXTCNT>0 D
-        .N OUTPUT,NLINES
-        .S NLINES=0 D FORMAT^PXRMTEXT(1,WIDTH,TXTCNT,.DTXT,.NLINES,.OUTPUT)
-        .I NLINES>0 K DTXT M DTXT=OUTPUT
-        S CNT=0
-        F  S CNT=$O(DTXT(CNT)) Q:CNT=""  D
-        .S TEXT=$G(DTXT(CNT)),VALMCNT=VALMCNT+1
-        .S ^TMP(NODE,$J,VALMCNT,0)=SEQ_TEXT,SEQ=$J("",$L(SEQ))
-        Q
-        ;
-ADD     ;PXRM DIALOG ADD ELEMENT validation
-        N ANS,DTOUT,DUOUT,LIT,LOCK,Y,PIEN,ERR,IEN,NATIONAL,SEQ
-        W IORESET
-        S VALMBCK="R",NATIONAL=0
-        I $P($G(^PXRMD(801.41,PXRMDIEN,100)),U)="N" S NATIONAL=1
-        S LOCK=$P($G(^PXRMD(801.41,PXRMDIEN,100)),U,4)
-        I NATIONAL,'($G(PXRMINST)=1)&(DUZ(0)="@"),$G(LOCK)'=1 D  Q
-        .W !,"Elements may not be added to national reminder dialogs" H 2
-        ;
-        F  D SEQ(.SEQ,.PIEN) Q:$D(DUOUT)!$D(DTOUT)  Q:SEQ
-        Q:$D(DUOUT)!$D(DTOUT)
-        ;
-        ;Check if sequence number is OK
-        I $G(PIEN)="" Q
-        S ANS="N" D ASK^PXRMDLG5(.ANS,PIEN) Q:$D(DUOUT)!$D(DTOUT)!($G(ANS)="N")
-        ;
-        ;Select a dialog element to add to parent dialog (PIEN)
-        ;PIEN may be dialog or a group within the dialog
-        D ESEL^PXRMDEDT(PIEN,SEQ)
-        ;Rebuild workfile
-        D BUILD^PXRMDLG(VIEW)
-        Q
-        ;
-FADD(DIEN,FTAB) ;Additional Findings
-        N FIND,FSUB,FTYP,FNAME,FNUM
-        S FSUB=0
-        F  S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB  D
-        .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) Q:FIND=""
-        .S FNAME="" D FDESC(FIND) Q:FNAME=""
-        .;Save additional finding name
-        .S FOUND=1 D FSAVE(2,FNAME,FTYP,FTAB,FIND)
-        Q
-        ;
-DETAIL(DIEN,LEV,VIEW,NODE)      ;;Build listman global for all components
-        N DDATA,DDLG,DEND,DCIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB
-        S DSEQ=0
-        ;
-        ;Get each sequence number
-        F  S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ  D
-        .;Determine subscript
-        .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
-        .;Get ien of prompt/component
-        .S DCIEN=$P($G(^PXRMD(801.41,DIEN,10,DSUB,0)),U,2) Q:'DCIEN
-        .I "PF"[$P($G(^PXRMD(801.41,DCIEN,0)),U,4) Q
-        .;Save line in workfile
-        .D DLINE(DCIEN,LEV,DSEQ,NODE)
-        .;Build pointers back to parent
-        .I VIEW'=4 D
-        ..S ^TMP("PXRMDLG4",$J,"IEN",NSEL)=DIEN_U_DSEQ
-        ..S ^TMP("PXRMDLG4",$J,"SEQ",LEV_DSEQ)=DCIEN
-        .;Process any sub-components
-        .I VIEW<5 D DETAIL(DCIEN,LEV_DSEQ_".",VIEW,NODE)
-        Q
-        ;
-DLINE(DIEN,LEV,DSEQ,NODE)       ;Save individual component details
-        N CNT,DBOX,DCAP,DDIS,DMULT,DSUPP,DSHOW,DTYP,DTXT
-        N IC,RESNM,RESULT,RIEN,RNAME,RCNT
-        ;Dialog name
-        S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM=""
-        ;Check if standard PXRM prompt
-        I $$PXRM^PXRMEXID(DNAM) Q
-        ;Dialog Type and Disabled
-        S DDIS=$P(DDATA,U,3),DTYP=$P(DDATA,U,4)
-        S DTYP=$S(DTYP="G":"Group",1:"Element"),DNAM=DTYP_": "_DNAM
-        I VIEW=5 S DNAM=DNAM
-        ;Resolution type and name
-        S RNAME="",RIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,3)
-        I RIEN S RNAME=$P($G(^PXRMD(801.9,RIEN,0)),U)
-        ;
-        ;Group fields
-        I DTYP="Group" D
-        .S DGRP=1,DTXT=$P(DDATA,U,5),DCAP=" [group caption]"
-        .I DTXT="" S DCAP=""
-        .I DTXT]"" S DCAP=DTXT_" "_DCAP
-        .S DBOX=$S($P(DDATA,U,6)="Y":"BOX",1:"NO BOX")
-        .S DSUPP=$S($P(DDATA,U,11):"SUPPRESS",1:"NO SUPPRESS")
-        .S DSHOW=$S($P(DDATA,U,10):"HIDE",1:"SHOW")
-        .S DMULT=$P(DDATA,U,9)
-        .S DMULT=$S(DMULT=1:"ONE ONLY",DMULT=2:"ONE OR MORE",DMULT=3:"NONE OR ONE",1:"NO SELECTION")
-        ;
-        N DPTX,DTXT,EXIST,ITEM,TEMP,SEP,SEQ,TAB,ALTLEN
-        S NSEL=NSEL+1,NLINE=NLINE+1,ITEM=NSEL,SEP=$E(LEV,$L(LEV)),SEQ=LEV_DSEQ
-        ;Suppress Item numbers for INQ options
-        I VIEW=4 S ITEM=""
-        ;Otherwise display Item, Sequence and Dialog Name
-        S TEMP=$J(ITEM,4)_$J("",3)_SEQ,TAB=$L(TEMP)+2
-        S CNT=0 F IC=1:1 Q:'$P(SEQ,".",IC)  S:$P(SEQ,".",IC)<10 CNT=CNT+1
-        S TAB=TAB+CNT
-        ;
-        S ALTLEN=$L(TEMP)
-        ;Display dialog name
-        S TEMP=TEMP_$J("",2+CNT)_DNAM
-        ;Add disabled if present
-        I DDIS]"" S TEMP=TEMP_" (Disabled)"
-        ;
-        S ^TMP(NODE,$J,NLINE,0)=TEMP
-        ;check for alternate dialog element/group
-        I VIEW<2!(VIEW>4) D
-        .I $D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
-        ;
-        ;Dialog Text or P/N Text
-        I (VIEW=2)!(VIEW=3)!(VIEW=4) D
-        .N DGBEG,DGSUB,TSUB
-        .S DGSUB=0,TSUB=$$TSUB^PXRMDLG1(DIEN,VIEW)
-        .I VIEW=4 S DGBEG=$J("",TAB)_"Text: "
-        .I VIEW'=4 S DGBEG=$J("",5+$L(SEQ)+CNT+$L(DTYP))_"Text: "
-        .D WP(DIEN,TSUB,65,.DGBEG,.NLINE)
-        .I DTYP="Group" D
-        ..S TEMP=DGBEG_"["_DBOX_", "_DSUPP_", "_DSHOW_", "_DMULT_"]"
-        ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
-        ;
-        ;Set up selection index
-        S ^TMP(NODE,$J,"IDX",NSEL,DIEN)=""
-        ;Insert finding items
-        I (VIEW=1)!(VIEW=4),("Element;Group"[DTYP) D
-        .N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTYP,TEMP
-        .;Findings
-        .S FNAME="",FOUND=0
-        .D FDESC($P($G(^PXRMD(801.41,DIEN,1)),U,5))
-        .I FNAME'="" S FOUND=1 D FSAVE(1,FNAME,FTYP,TAB)
-        .;Resolution
-        .I RNAME]"" D
-        ..S TEMP=$J("",TAB)_"Resolution: "_RNAME
-        ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
-        .;Result Group
-        .I VIEW=4 D
-        ..S RCNT=0 F  S RCNT=$O(^PXRMD(801.41,DIEN,51,RCNT)) Q:RCNT'>0  D
-        ...S RESULT=$P($G(^PXRMD(801.41,DIEN,51,RCNT,0)),U)
-        ...S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U) Q:RESNM=""
-        ...S TEMP=$J("",TAB)_"Result Group: "_RESNM
-        ...S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
-        .;Additional findings
-        .D FADD(DIEN,TAB)
-        ;Get additional prompts
-        I VIEW=2 D
-        .S FIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
-        .I $G(FIEN)["PXD(811.2," D TAX^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
-        .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
-        .D FADD(DIEN,TAB)
-        I VIEW,VIEW<5,"Element;Group"[DTYP D PROMPT(DIEN,TAB,"Prompts: ",VIEW)
-        ;
-        I VIEW=4,$D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
-        S NLINE=NLINE+1
-        S ^TMP(NODE,$J,NLINE,0)=$J("",79)
-        Q
-        ;
-FDESC(FIEN)     ;Finding description
-        N FGLOB,FITEM,FNUM
-        S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
-        S FITEM=$P(FIEN,";") Q:FITEM=""
-        S FNUM=" ["_FITEM_"]"
-        I FGLOB["ICD9" D  Q
-        .S FTYP="DIAGNOSIS",FGLOB=U_FGLOB_FITEM_",0)"
-        .S FNAME=$P($G(@FGLOB),U,3)_FNUM
-        I FGLOB["WV" D  Q
-        .S FTYP="WH NOTIFICATION PURPOSE",FGLOB=U_FGLOB_FITEM_",0)"
-        .S FNAME=$P($G(@FGLOB),U)_FNUM
-        I FGLOB["ICPT" D  Q
-        .S FTYP="PROCEDURE",FGLOB=U_FGLOB_FITEM_",0)"
-        .S FNAME=$P($G(@FGLOB),U,2)_FNUM
-        I FGLOB["ORD(101.41" D  Q
-        .S FTYP="QUICK ORDER",FGLOB=U_FGLOB_FITEM_",0)"
-        .S FNAME=$P($G(@FGLOB),U,2)_FNUM
-        ;Short name for finding type
-        S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
-        ;Long name
-        S FTYP=$G(DEF2(FTYP))
-        S FGLOB=U_FGLOB_FITEM_",0)"
-        S FNAME=$P($G(@FGLOB),U,1)_FNUM
-        I FNAME="" S FNAME=$P($G(@FGLOB),U)_FNUM
-        I FNAME="" S FNAME=FITEM
-        Q
-        ;
-FSAVE(DSUB,FNAME,FTYP,FTAB,FIEN)        ;Save finding details
-        N TEMP
-        I DSUB=1 S FLIT="Finding: "
-        I DSUB>1 S FLIT="Add. Finding: "
-        S FLONG=0
-        ;change code to use IOM instead of default length of 60
-        I $L(FLIT_FNAME_" ("_FTYP_")")>(IOM-20) S FLONG=1
-        I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
-        I FLONG S FNAME=FLIT_FNAME
-        S TEMP=$J("",FTAB)_$E(FNAME,1,(IOM-20))_$J("",60-$L(FNAME))
-        S NLINE=NLINE+1
-        S ^TMP(NODE,$J,NLINE,0)=TEMP
-        I FLONG S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
-        I VIEW=2 D
-        .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
-        Q
-        ;
-PROMPT(IEN,TAB,TEXT,VIEW)       ;additional prompts in the dialog file
-        N DATA,DDIS,DGSEQ,DSUB,DTITLE,DTXT,DTYP,SEQ,SUB
-        S SEQ=0
-        F  S SEQ=$O(^PXRMD(801.41,IEN,10,"B",SEQ)) Q:'SEQ  D
-        .S SUB=$O(^PXRMD(801.41,IEN,10,"B",SEQ,"")) Q:'SUB
-        .S DSUB=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,2) Q:'DSUB 
-        .S DATA=$G(^PXRMD(801.41,DSUB,0)) Q:DATA=""
-        .S DNAME=$P(DATA,U),DDIS=$P(DATA,U,3),DTYP=$P(DATA,U,4)
-        .I "PF"'[DTYP Q
-        .I DTYP="F" S DNAME=DNAME_" (forced value)"
-        .I DTYP="P",(VIEW=2)!(VIEW=3) D
-        ..;Override prompt caption
-        ..S DTITLE=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,6)
-        ..I DTITLE="" S DTITLE=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
-        ..S DNAME=DTITLE
-        .S DNAME=$J("",TAB)_TEXT_DNAME
-        .S:DDIS]"" DNAME=DNAME_" (Disabled)"
-        .S NLINE=NLINE+1
-        .S ^TMP(NODE,$J,NLINE,0)=DNAME
-        .S TEXT=$J("",$L(TEXT))
-        Q
-        ;
-SEQ(SEQ,PIEN)   ;Select sequence number to add
-        N X,Y,TEXT,DIR
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S SEQ=0
-        S DIR(0)="FA0;1;30"
-        S DIR("A")="Enter a new SEQUENCE NUMBER: "
-        S DIR("?")="Enter new sequence number. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMDLG4(1)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        ;
-        ;Check that sequence number is new 
-        I $D(^TMP("PXRMDLG4",$J,"SEQ",X)) D  Q
-        .W !,"Sequence number "_X_" already in use."
-        ;
-        ;Then check that the parent is a group or reminder dialog
-        I X["." D  Q:X=""
-        .N CLASS,SUB
-        .;Sequence number of parent
-        .S SUB=$P(X,".",1,$L(X,".")-1)
-        .I $G(SUB)=""!($G(SUB)=0) W !,"Invalid sequence number. A sequence number cannot be less then 1" H 2 Q
-        .;Get IEN of parent dialog or group
-        .S PIEN=$G(^TMP("PXRMDLG4",$J,"SEQ",SUB))
-        .;Validate sequence number
-        .I 'PIEN W !,"Sequence number is not part of an existing group." S X="" Q
-        .;Validate that the parent is a group or reminder dialog
-        .I "RG"'[$P($G(^PXRMD(801.41,PIEN,0)),U,4) D  S X="" Q
-        ..W !,"New sequences can only be added to groups or reminder dialogs"
-        .;Disallow adding elements to national dialogs or groups
-        .I $P($G(^PXMRD(801.41,PIEN,100)),U)="N" D  Q:X=""
-        ..Q:(DUZ(0)="@")&($G(PXRMINST)=1)
-        ..W !,"Elements cannot be added to a national group" S X=""
-        ;
-        ;If adding to top level parent ien is reminder dialog
-        I X?.N S PIEN=PXRMDIEN
-        ;
-        S SEQ=$P(X,".",$L(X,"."))
-        Q
-        ;
-        ;
-HELP(CALL)      ;General help text routine.
-        N HTEXT
-        N DIWF,DIWL,DIWR,IC
-        S DIWF="C75",DIWL=0,DIWR=75
-        ;
-        I CALL=1 D
-        .S HTEXT(1)="Sequence numbers can be added at any level. Specify the full"
-        .S HTEXT(2)="number for the level required (e.g. 15.10.20)."
-        ;
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
+PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;10/31/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+WP(SUB,SUB1,WIDTH,SEQ,VALMCNT) ;Format WP text
+ N DIWF,DIWL,DIWR,IC,TEXT,X,TXTCNT,DTXT,CNT,SUB2
+ S (CNT,SUB2,TXTCNT)=0
+ F  S SUB2=$O(^PXRMD(801.41,SUB,SUB1,SUB2)) Q:'SUB2  D
+ .S TXTCNT=TXTCNT+1,DTXT(TXTCNT)=$G(^PXRMD(801.41,SUB,SUB1,SUB2,0))
+ .S DTXT(TXTCNT)=$$STRREP^PXRMUTIL($G(DTXT(TXTCNT)),"<br>","\\")
+ I TXTCNT>0 D
+ .N OUTPUT,NLINES
+ .S NLINES=0 D FORMAT^PXRMTEXT(1,WIDTH,TXTCNT,.DTXT,.NLINES,.OUTPUT)
+ .I NLINES>0 K DTXT M DTXT=OUTPUT
+ S CNT=0
+ F  S CNT=$O(DTXT(CNT)) Q:CNT=""  D
+ .S TEXT=$G(DTXT(CNT)),VALMCNT=VALMCNT+1
+ .S ^TMP(NODE,$J,VALMCNT,0)=SEQ_TEXT,SEQ=$J("",$L(SEQ))
+ Q
+ ;
+ADD ;PXRM DIALOG ADD ELEMENT validation
+ N ANS,DTOUT,DUOUT,LIT,LOCK,Y,PIEN,ERR,IEN,NATIONAL,SEQ
+ W IORESET
+ S VALMBCK="R",NATIONAL=0
+ ;Check if national reminder dialog
+ I $P($G(^PXRMD(801.41,PXRMDIEN,100)),U)="N" S NATIONAL=1
+ S LOCK=$P($G(^PXRMD(801.41,PXRMDIEN,100)),U,4)
+ ;Dissallow editing of national dialogs
+ I NATIONAL,'($G(PXRMINST)=1)&(DUZ(0)="@"),$G(LOCK)'=1 D  Q
+ .W !,"Elements may not be added to national reminder dialogs" H 2
+ ;
+ F  D SEQ(.SEQ,.PIEN) Q:$D(DUOUT)!$D(DTOUT)  Q:SEQ
+ Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ ;Check if sequence number is OK
+ I $G(PIEN)="" Q
+ S ANS="N" D ASK^PXRMDLG5(.ANS,PIEN) Q:$D(DUOUT)!$D(DTOUT)!($G(ANS)="N")
+ ;
+ ;Select a dialog element to add to parent dialog (PIEN)
+ ;PIEN may be dialog or a group within the dialog
+ D ESEL^PXRMDEDT(PIEN,SEQ)
+ ;Rebuild workfile
+ D BUILD^PXRMDLG(VIEW)
+ Q
+ ;
+FADD(DIEN,FTAB) ;Additional Findings
+ N FIND,FSUB,FTYP,FNAME,FNUM
+ S FSUB=0
+ F  S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB  D
+ .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) Q:FIND=""
+ .S FNAME="" D FDESC(FIND) Q:FNAME=""
+ .;Save additional finding name
+ .S FOUND=1 D FSAVE(2,FNAME,FTYP,FTAB,FIND)
+ Q
+ ;
+DETAIL(DIEN,LEV,VIEW,NODE) ;;Build listman global for all components
+ N DDATA,DDLG,DEND,DCIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB
+ S DSEQ=0
+ ;
+ ;Get each sequence number
+ F  S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ  D
+ .;Determine subscript
+ .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
+ .;Get ien of prompt/component
+ .S DCIEN=$P($G(^PXRMD(801.41,DIEN,10,DSUB,0)),U,2) Q:'DCIEN
+ .;Ignore prompts and forced values
+ .I "PF"[$P($G(^PXRMD(801.41,DCIEN,0)),U,4) Q
+ .;Save line in workfile
+ .D DLINE(DCIEN,LEV,DSEQ,NODE)
+ .;Build pointers back to parent
+ .I VIEW'=4 D
+ ..S ^TMP("PXRMDLG4",$J,"IEN",NSEL)=DIEN_U_DSEQ
+ ..S ^TMP("PXRMDLG4",$J,"SEQ",LEV_DSEQ)=DCIEN
+ .;Process any sub-components
+ .I VIEW<5 D DETAIL(DCIEN,LEV_DSEQ_".",VIEW,NODE)
+ Q
+ ;
+DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
+ N CNT,DBOX,DCAP,DDIS,DMULT,DSUPP,DSHOW,DTYP,DTXT
+ N IC,RESNM,RESULT,RIEN,RNAME
+ ;Dialog name
+ S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM=""
+ ;Check if standard PXRM prompt
+ I $$PXRM^PXRMEXID(DNAM) Q
+ ;Dialog Type and Disabled
+ S DDIS=$P(DDATA,U,3),DTYP=$P(DDATA,U,4)
+ S DTYP=$S(DTYP="G":"Group",1:"Element"),DNAM=DTYP_": "_DNAM
+ I VIEW=5 S DNAM=DNAM
+ ;Resolution type and name
+ S RNAME="",RIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,3)
+ I RIEN S RNAME=$P($G(^PXRMD(801.9,RIEN,0)),U)
+ ;Result Group
+ S RESULT=$P(DDATA,U,15)
+ I RESULT S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U)
+ ;
+ ;Group fields
+ I DTYP="Group" D
+ .S DGRP=1,DTXT=$P(DDATA,U,5),DCAP=" [group caption]"
+ .I DTXT="" S DCAP=""
+ .I DTXT]"" S DCAP=DTXT_" "_DCAP
+ .S DBOX=$S($P(DDATA,U,6)="Y":"BOX",1:"NO BOX")
+ .S DSUPP=$S($P(DDATA,U,11):"SUPPRESS",1:"NO SUPPRESS")
+ .S DSHOW=$S($P(DDATA,U,10):"HIDE",1:"SHOW")
+ .S DMULT=$P(DDATA,U,9)
+ .S DMULT=$S(DMULT=1:"ONE ONLY",DMULT=2:"ONE OR MORE",DMULT=3:"NONE OR ONE",1:"NO SELECTION")
+ ;
+ N DPTX,DTXT,EXIST,ITEM,TEMP,SEP,SEQ,TAB,ALTLEN
+ S NSEL=NSEL+1,NLINE=NLINE+1,ITEM=NSEL,SEP=$E(LEV,$L(LEV)),SEQ=LEV_DSEQ
+ ;Suppress Item numbers for INQ options
+ I VIEW=4 S ITEM=""
+ ;Otherwise display Item, Sequence and Dialog Name
+ S TEMP=$J(ITEM,4)_$J("",3)_SEQ,TAB=$L(TEMP)+2
+ S CNT=0 F IC=1:1 Q:'$P(SEQ,".",IC)  S:$P(SEQ,".",IC)<10 CNT=CNT+1
+ S TAB=TAB+CNT
+ ;
+ S ALTLEN=$L(TEMP)
+ ;Display dialog name
+ S TEMP=TEMP_$J("",2+CNT)_DNAM
+ ;Add disabled if present
+ I DDIS]"" S TEMP=TEMP_" (Disabled)"
+ ;
+ S ^TMP(NODE,$J,NLINE,0)=TEMP
+ ;check for alternate dialog element/group
+ I VIEW<2!(VIEW>4) D
+ .I $D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
+ ;
+ ;Dialog Text or P/N Text
+ I (VIEW=2)!(VIEW=3)!(VIEW=4) D
+ .N DGBEG,DGSUB,TSUB
+ .S DGSUB=0,TSUB=$$TSUB^PXRMDLG1(DIEN,VIEW)
+ .I VIEW=4 S DGBEG=$J("",TAB)_"Text: "
+ .I VIEW'=4 S DGBEG=$J("",5+$L(SEQ)+CNT+$L(DTYP))_"Text: "
+ .D WP(DIEN,TSUB,65,.DGBEG,.NLINE)
+ .I DTYP="Group" D
+ ..S TEMP=DGBEG_"["_DBOX_", "_DSUPP_", "_DSHOW_", "_DMULT_"]"
+ ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
+ ;
+ ;Set up selection index
+ S ^TMP(NODE,$J,"IDX",NSEL,DIEN)=""
+ ;Insert finding items
+ I (VIEW=1)!(VIEW=4),("Element;Group"[DTYP) D
+ .N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTYP,TEMP
+ .;Findings
+ .S FNAME="",FOUND=0
+ .D FDESC($P($G(^PXRMD(801.41,DIEN,1)),U,5))
+ .I FNAME'="" S FOUND=1 D FSAVE(1,FNAME,FTYP,TAB)
+ .;Resolution
+ .I RNAME]"" D
+ ..S TEMP=$J("",TAB)_"Resolution: "_RNAME
+ ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
+ .;Additional findings
+ .D FADD(DIEN,TAB)
+ ;Get additional prompts
+ I VIEW=2 D
+ .S FIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
+ .I $G(FIEN)["PXD(811.2," D TAX^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
+ .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
+ .D FADD(DIEN,TAB)
+ I VIEW,VIEW<5,"Element;Group"[DTYP D PROMPT(DIEN,TAB,"Prompts: ",VIEW)
+ ;
+ I VIEW=4,$D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN)
+ S NLINE=NLINE+1
+ S ^TMP(NODE,$J,NLINE,0)=$J("",79)
+ Q
+ ;
+FDESC(FIEN) ;Finding description
+ N FGLOB,FITEM,FNUM
+ ;Determine finding type
+ S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
+ S FITEM=$P(FIEN,";") Q:FITEM=""
+ S FNUM=" ["_FITEM_"]"
+ I FGLOB["ICD9" D  Q
+ .S FTYP="DIAGNOSIS",FGLOB=U_FGLOB_FITEM_",0)"
+ .S FNAME=$P($G(@FGLOB),U,3)_FNUM
+ I FGLOB["WV" D  Q
+ .S FTYP="WH NOTIFICATION PURPOSE",FGLOB=U_FGLOB_FITEM_",0)"
+ .S FNAME=$P($G(@FGLOB),U)_FNUM
+ I FGLOB["ICPT" D  Q
+ .S FTYP="PROCEDURE",FGLOB=U_FGLOB_FITEM_",0)"
+ .S FNAME=$P($G(@FGLOB),U,2)_FNUM
+ I FGLOB["ORD(101.41" D  Q
+ .S FTYP="QUICK ORDER",FGLOB=U_FGLOB_FITEM_",0)"
+ .S FNAME=$P($G(@FGLOB),U,2)_FNUM
+ ;Short name for finding type
+ S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
+ ;Long name
+ S FTYP=$G(DEF2(FTYP))
+ S FGLOB=U_FGLOB_FITEM_",0)"
+ S FNAME=$P($G(@FGLOB),U,1)_FNUM
+ I FNAME="" S FNAME=$P($G(@FGLOB),U)_FNUM
+ I FNAME="" S FNAME=FITEM
+ Q
+ ;
+FSAVE(DSUB,FNAME,FTYP,FTAB,FIEN) ;Save finding details
+ N TEMP
+ I DSUB=1 S FLIT="Finding: "
+ I DSUB>1 S FLIT="Add. Finding: "
+ S FLONG=0
+ ;change code to use IOM instead of default length of 60
+ I $L(FLIT_FNAME_" ("_FTYP_")")>(IOM-20) S FLONG=1
+ I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
+ I FLONG S FNAME=FLIT_FNAME
+ S TEMP=$J("",FTAB)_$E(FNAME,1,(IOM-20))_$J("",60-$L(FNAME))
+ S NLINE=NLINE+1
+ S ^TMP(NODE,$J,NLINE,0)=TEMP
+ I FLONG S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
+ I VIEW=2 D
+ .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE)
+ Q
+ ;
+PROMPT(IEN,TAB,TEXT,VIEW) ;additional prompts in the dialog file
+ N DATA,DDIS,DGSEQ,DSUB,DTITLE,DTXT,DTYP,SEQ,SUB
+ S SEQ=0
+ F  S SEQ=$O(^PXRMD(801.41,IEN,10,"B",SEQ)) Q:'SEQ  D
+ .S SUB=$O(^PXRMD(801.41,IEN,10,"B",SEQ,"")) Q:'SUB
+ .S DSUB=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,2) Q:'DSUB 
+ .S DATA=$G(^PXRMD(801.41,DSUB,0)) Q:DATA=""
+ .S DNAME=$P(DATA,U),DDIS=$P(DATA,U,3),DTYP=$P(DATA,U,4)
+ .I "PF"'[DTYP Q
+ .I DTYP="F" S DNAME=DNAME_" (forced value)"
+ .I DTYP="P",(VIEW=2)!(VIEW=3) D
+ ..;Override prompt caption
+ ..S DTITLE=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,6)
+ ..I DTITLE="" S DTITLE=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
+ ..S DNAME=DTITLE
+ .S DNAME=$J("",TAB)_TEXT_DNAME
+ .S:DDIS]"" DNAME=DNAME_" (Disabled)"
+ .S NLINE=NLINE+1
+ .S ^TMP(NODE,$J,NLINE,0)=DNAME
+ .S TEXT=$J("",$L(TEXT))
+ Q
+ ;
+SEQ(SEQ,PIEN) ;Select sequence number to add
+ N X,Y,TEXT,DIR
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S SEQ=0
+ S DIR(0)="FA0;1;30"
+ S DIR("A")="Enter a new SEQUENCE NUMBER: "
+ S DIR("?")="Enter new sequence number. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMDLG4(1)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ ;
+ ;Check that sequence number is new 
+ I $D(^TMP("PXRMDLG4",$J,"SEQ",X)) D  Q
+ .W !,"Sequence number "_X_" already in use."
+ ;
+ ;Then check that the parent is a group or reminder dialog
+ I X["." D  Q:X=""
+ .N CLASS,SUB
+ .;Sequence number of parent
+ .S SUB=$P(X,".",1,$L(X,".")-1)
+ .I $G(SUB)=""!($G(SUB)=0) W !,"Invalid sequence number. A sequence number cannot be less then 1" H 2 Q
+ .;Get IEN of parent dialog or group
+ .S PIEN=$G(^TMP("PXRMDLG4",$J,"SEQ",SUB))
+ .;Validate sequence number
+ .I 'PIEN W !,"Sequence number is not part of an existing group." S X="" Q
+ .;Validate that the parent is a group or reminder dialog
+ .I "RG"'[$P($G(^PXRMD(801.41,PIEN,0)),U,4) D  S X="" Q
+ ..W !,"New sequences can only be added to groups or reminder dialogs"
+ .;Disallow adding elements to national dialogs or groups
+ .I $P($G(^PXMRD(801.41,PIEN,100)),U)="N" D  Q:X=""
+ ..Q:(DUZ(0)="@")&($G(PXRMINST)=1)
+ ..W !,"Elements cannot be added to a national group" S X=""
+ ;
+ ;If adding to top level parent ien is reminder dialog
+ I X?.N S PIEN=PXRMDIEN
+ ;
+ S SEQ=$P(X,".",$L(X,"."))
+ Q
+ ;
+ ;
+HELP(CALL) ;General help text routine.
+ N HTEXT
+ N DIWF,DIWL,DIWR,IC
+ S DIWF="C75",DIWL=0,DIWR=75
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="Sequence numbers can be added at any level. Specify the full"
+ .S HTEXT(2)="number for the level required (e.g. 15.10.20)."
+ ;
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m

@@ -1 @@
-PXRMDLG5        ; SLC/PJH - Reminder Dialog Edit/Inquiry ;11/08/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN)   ;
-        ;Display branching logic text in dialog summary view
-        N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
-        S DATA=$G(^PXRMD(801.41,DIEN,49))
-        I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
-        S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
-        S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
-        I +$P(DATA,U,3)>0 D
-        .S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
-        .S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
-        I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
-        I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
-        D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
-        Q
-        ;
-ASK(YESNO,PIEN) ;Confirm
-        K DIR,DIROUT,DIRUT,DNAME,DTOUT,DTYP,DUOUT,TEXT,X,Y
-        N DDATA,DNAME,DTYP
-        S DDATA=$G(^PXRMD(801.41,PIEN,0))
-        ;Parent name and type
-        S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4)
-        ;
-        S DIR(0)="YA0"
-        S DIR("A")="Add sequence "_SEQ_" to "
-        I DTYP="G" S DIR("A")=DIR("A")_"group "_DNAME_": "
-        E  S DIR("A")=DIR("A")_"reminder dialog ?: "
-        S DIR("B")="N",DIR("?")="Enter Y or N. For detailed help type ??"
-        S DIR("??")=U_"D XHLP^PXRMDLG(1)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        S YESNO=$E(Y(0)) I YESNO'="Y" S DUOUT=1
-        S VALMBCK="R"
-        Q
-        ;
-BHELP(VALUE)    ;
-        N HTEXT
-        D FULL^VALM1
-        ;Help text for Reminder Dialog Branching logic
-        I VALUE=1 D
-        .;Reminder Term field
-        .S HTEXT(1)="Enter a reminder term that will be used to determine if the reminder"
-        .S HTEXT(2)="element/group should be replaced or suppressed if the reminder term evaluation"
-        .S HTEXT(3)="matches the value in the Reminder Term Status field."
-        I VALUE=2 D
-        .;Reminder Term Status field
-        .S HTEXT(1)="Enter either 1 for true or 0 for false. This value will be used with the"
-        .S HTEXT(2)="reminder term field to determine if this item should be replaced with a"
-        .S HTEXT(3)="different element/group defined in the Replacement Element/Group field, or if"
-        .S HTEXT(4)="this item should be suppressed."
-        I VALUE=3 D
-        .;Replacement Element/Group field
-        .S HTEXT(1)="Enter an element/group that will be used as a replacement to thisitem, or"
-        .S HTEXT(2)="leave this field blank to suppress this item if the term evaluation"
-        .S HTEXT(3)="matches the value defined in the term status field. "
-        I VALUE=4 D
-        .;Patient Specific field
-        .S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set to true"
-        .S HTEXT(2)="if item in this dialog will be using reminder term to either replace an item"
-        .S HTEXT(3)="or to suppress an item."
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-INQ(DIEN)       ;INQ Inquiry/Print option
-        ; Used by 801.41 print templates
-        ; [PXRM REMINDER DIALOG]
-        ; [PXRM DIALOG GROUP]
-        ;
-        N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
-        N NLINE,NODE,NSEL,SUB
-        S NLINE=0,NODE="PXRMDLG4",NSEL=0
-        K ^TMP(NODE,$J)
-        ;
-        ;Components
-        W !!,"      Seq.       Dialog",!
-        D DETAIL^PXRMDLG4(DIEN,"",4,NODE)
-        ;
-        ;Print lines from workfile
-        S SUB=""
-        F  S SUB=$O(^TMP(NODE,$J,SUB)) Q:'SUB  W !,^TMP(NODE,$J,SUB,0)
-        K ^TMP(NODE,$J)
-        Q
-        ;
-MH(IEN) ;Allow IEN=109 (HX2) as a place holder for 601 entries that do not
-        ;have a corresponding 601.71 entry.
-        I IEN=109 Q 1
-        I $G(PXRMINST)=1 Q 1
-        N MAXNUM
-        S MAXNUM=+$P($G(^PXRM(800,1,"MH")),U)
-        I MAXNUM=0 S MAXNUM=25
-        Q $$ONECR^YTQPXRM5(IEN,MAXNUM)
-        ;
-MHLICR(IEN)     ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
-        ;branching works.
-        N Y
-        ;DBIA #5042
-        I $$RL^YTQPXRM3(IEN)="Y" D
-        .W !,"This MH test requires a license."
-        .W !,"The question text will not appear in the progress note.",!
-        .H 1
-        Q
-        ;
-MSEL(NUM)       ;
-        I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
-        Q 1
-        ;
-MHREQHLP        ;
-        N TEXT
-        S TEXT(1)="Select 0, ""Optional open and optional complete (partial complete possible)"","
-        S TEXT(2)="if the user should be able to optionally select/open the MH test in the reminder dialog and optionally complete the MH test before the reminder dialog can be finished."
-        S TEXT(3)=" "
-        S TEXT(4)="Select 1, ""Required open and required complete before finish"","
-        S TEXT(5)="if the user is required to select/open and complete the MH test in the reminder dialog before the reminder dialog can be finished."
-        S TEXT(6)=" "
-        S TEXT(7)="Select 2, ""Optional open and required complete or cancel before finish"","
-        S TEXT(8)="if the user should be able to optionally select/open the MH test in the reminder dialog; however, if the user opens the MH test, then the user is required to complete or cancel the MH test before the reminder dialog can be finished."
-        S TEXT(9)=" "
-        S TEXT(10)="Note: Clicking the cancel button in the MH Test is considered the same as not opening the MH Test."
-        S TEXT(11)="Also, Option 2, ""Optional open and required complete or cancel before finish"", only works with CPRS 27 and"
-        S TEXT(12)="YS_MHA.dll. If Option 2 is selected and the user is using a pre-CPRS 27 version this option will be treated by CPRS as Option 1, ""Required open and required complete before finish""."
-        D HELP^PXRMEUT(.TEXT)
-        Q
-        ;
-NTERM(DA,OTERM,NTERM)   ;
-        I +OTERM=0 S OTERM=$P($G(DA),U)
-        I +NTERM=0 K OTERM Q 2
-        I +OTERM=0,+NTERM>0 K OTERM Q 1
-        I +OTERM'=+NTERM K OTERM Q 0
-        K OTERM
-        Q 1
-        ;
-OTERM(DA)       ;
-        K OTERM
-        S OTERM=$P($G(^PXRMD(801.41,DA,49)),U)
-        Q
-        ;
-RESCHK(IEN)     ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
-        ;branching works.
-        N CNT,FDA,MSG,RG,RGIEN,VALID,Y
-        S CNT=0
-        F  S CNT=$O(^PXRMD(801.41,IEN,51,CNT)) Q:CNT'>0  D
-        .S RGIEN=$P($G(^PXRMD(801.41,IEN,51,CNT,0)),U) I +RGIEN'>0 Q
-        .S RG=$P($G(^PXRMD(801.41,RGIEN,0)),U,1)
-        .I RG="" Q
-        .S VALID=$$RGLSCR(IEN,RG,RGIEN)
-        .I VALID Q
-        .W !,"Deleting the result group ",RG," from the element/group."
-        .S FDA(801.41121,CNT_","_IEN_",",.01)="@"
-        .D FILE^DIE("E","FDA","MSG")
-        .S RGKILL=1
-        .I $D(MSG) D AWRITE^PXRMUTIL("MSG")
-        Q
-        ;
-RSELEDIT(DA)    ;
-        N NODE,RESULT
-        ;RESULT=0 EDIT NOTHING
-        ;RESULT=1 EDIT INFORMATIONAL TEXT
-        ;RESULT=2 EDIT EVERYTHING
-        S RESULT=2
-        I $G(PXRMINST)=1,DUZ(0)="@" Q RESULT
-        S NODE=$G(^PXRMD(801.41,DA,100))
-        I $P(NODE,U)="N" S RESULT=0
-        I RESULT=0,+$P(NODE,U,4)=0 S RESULT=1
-        Q RESULT
-        ;
-RGLSCR(DA,X,IEN)        ;Input transform/screen for RESULT GROUP LIST
-        I $G(PXRMINST)=1 Q 1
-        I $G(PXRMEXCH)=1 Q 1
-        N HELP,MHTEST,TEXT,VALID,Y
-        S NMATCH=0
-        S MHTEST=$O(^PXRMD(801.41,"B",X),-1)
-        F  S MHTEST=$O(^PXRMD(801.41,"B",MHTEST)) Q:(NMATCH>1)!(MHTEST'[X)  S NMATCH=NMATCH+1
-        ;If there is an exact match to the user's input turn help on.
-        S HELP=$S($G(DIQUIET):0,NMATCH=1:1,1:0)
-        S VALID=1
-        ;Make sure the TYPE is a result group
-        I '$D(^PXRMD(801.41,"TYPE","S",IEN)) D
-        . I HELP S TEXT(1)="TYPE must be a result group."
-        . S VALID=0
-        ;Make sure the finding item for the element matches the 
-        ;MH Test assigned to the Result Group
-        S MHTEST=+$P($G(^PXRMD(801.41,DA,1)),U,5) I MHTEST="" D
-        . I HELP S TEXT(2)="The MH test is missing."
-        . S VALID=0
-        I +$P($G(^PXRMD(801.41,IEN,50)),U)'=MHTEST D
-        . I HELP S TEXT(3)="The finding item does not match the MH Test assigned to the Result Group"
-        . S VALID=0
-        ;Make sure a scale has been defined.
-        I +$P($G(^PXRMD(801.41,IEN,50)),U,2)'>0 D
-        . I HELP S TEXT(4)="An MH Scale must be defined."
-        . S VALID=0
-        ;Make sure it is not disabled.
-        I $P($G(^PXRMD(801.41,IEN,0)),U,3)'="" D
-        . S VALID=0
-        . I HELP D
-        .. N EM,TYPE
-        .. S TYPE=$P(^PXRMD(801.41,IEN,0),U,4)
-        .. S TYPE=$$EXTERNAL^DILFD(801.41,4,"",TYPE,.EM)
-        .. S TEXT(5)="The "_TYPE_" is disabled."
-        I HELP,'VALID D EN^DDIOL(.TEXT)
-        Q VALID
-        ;
-TERMS(DA,X)     ;
-        N TERM
-        S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
-        I +TERM=0 D  Q 0
-        .W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
-        .H 2
-        I +TERM>0,$G(X)="" Q 2
-        Q 1
-        ;
-TEXT(NLINES,CNT,ATLEN,TEMP,NODE)        ;
-        N CNT1,NOUT,OUTPUT,WIDHT
-        S WIDTH=IOM-(2+(CNT+ATLEN))
-        S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
-        I NOUT>0 F CNT1=1:1:NOUT D
-        .S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
-        Q
-        ;
+PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;05/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;
+ASK(YESNO,PIEN) ;Confirm
+ K DIR,DIROUT,DIRUT,DNAME,DTOUT,DTYP,DUOUT,TEXT,X,Y
+ N DDATA,DNAME,DTYP
+ S DDATA=$G(^PXRMD(801.41,PIEN,0))
+ ;Parent name and type
+ S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4)
+ ;
+ S DIR(0)="YA0"
+ S DIR("A")="Add sequence "_SEQ_" to "
+ I DTYP="G" S DIR("A")=DIR("A")_"group "_DNAME_": "
+ E  S DIR("A")=DIR("A")_"reminder dialog ?: "
+ S DIR("B")="N",DIR("?")="Enter Y or N. For detailed help type ??"
+ S DIR("??")=U_"D XHLP^PXRMDLG(1)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ S YESNO=$E(Y(0)) I YESNO'="Y" S DUOUT=1
+ S VALMBCK="R"
+ Q
+ ;
+MSEL(NUM) ;
+ I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
+ Q 1
+ ;
+ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
+ ;Display branching logic text in dialog summary view
+ N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
+ S DATA=$G(^PXRMD(801.41,DIEN,49))
+ I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
+ S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
+ S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
+ I +$P(DATA,U,3)>0 D
+ .S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
+ .S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
+ I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
+ I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
+ D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
+ Q
+ ;
+OTERM(DA) ;
+ K OTERM
+ S OTERM=$P($G(^PXRMD(801.41,DA,49)),U) Q
+ ;
+NTERM(DA,OTERM,NTERM) ;
+ I +OTERM=0 S OTERM=$P($G(DA),U)
+ I +NTERM=0 K OTERM Q 2
+ I +OTERM=0,+NTERM>0 K OTERM Q 1
+ I +OTERM'=+NTERM K OTERM Q 0
+ K OTERM
+ Q 1
+ ;
+TERMS(DA,X) ;
+ N TERM
+ S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
+ I +TERM=0 D  Q 0
+ .W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
+ .H 2
+ I +TERM>0,$G(X)="" Q 2
+ Q 1
+ ;
+BHELP(VALUE) ;
+ N HTEXT
+ D FULL^VALM1
+ ;Help text for Reminder Dialog Branching logic
+ I VALUE=1 D
+ .;Reminder Term field
+ .S HTEXT(1)="Enter a reminder term that will be used to determine if the reminder"
+ .S HTEXT(2)="element/group should be replaced or suppressed if the reminder term evaluation"
+ .S HTEXT(3)="matches the value in the Reminder Term Status field."
+ I VALUE=2 D
+ .;Reminder Term Status field
+ .S HTEXT(1)="Enter either 1 for true or 0 for false. This value will be used with the"
+ .S HTEXT(2)="reminder term field to determine if this item should be replaced with a"
+ .S HTEXT(3)="different element/group defined in the Replacement Element/Group field, or if"
+ .S HTEXT(4)="this item should be suppressed."
+ I VALUE=3 D
+ .;Replacement Element/Group field
+ .S HTEXT(1)="Enter an element/group that will be used as a replacement to thisitem, or"
+ .S HTEXT(2)="leave this field blank to suppress this item if the term evaluation"
+ .S HTEXT(3)="matches the value defined in the term status field. "
+ I VALUE=4 D
+ .;Patient Specific field
+ .S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set totrue"
+ .S HTEXT(2)="if item in this dialog will be using reminder term to either replace an item"
+ .S HTEXT(3)="or to suppress an item."
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+TEXT(NLINES,CNT,ATLEN,TEMP,NODE) ;
+ N CNT1,NOUT,OUTPUT,WIDHT
+ S WIDTH=IOM-(2+(CNT+ATLEN))
+ S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
+ I NOUT>0 F CNT1=1:1:NOUT D
+ .S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
+ Q
+ ;
+INQ(DIEN) ;INQ Inquiry/Print option
+ ;
+ ; Used by 801.41 print templates
+ ; [PXRM REMINDER DIALOG]
+ ; [PXRM DIALOG GROUP]
+ ;
+ N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
+ N NLINE,NODE,NSEL,SUB
+ S NLINE=0,NODE="PXRMDLG4",NSEL=0
+ K ^TMP(NODE,$J)
+ ;
+ ;Components
+ W !!,"      Seq.       Dialog",!
+ D DETAIL^PXRMDLG4(DIEN,"",4,NODE)
+ ;
+ ;Print lines from workfile
+ S SUB=""
+ F  S SUB=$O(^TMP(NODE,$J,SUB)) Q:'SUB  W !,^TMP(NODE,$J,SUB,0)
+ K ^TMP(NODE,$J)
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m

@@ -1 @@
-PXRMDLGZ        ; SLC/PJH - Link reminder to dialog. ;01/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Called by option PXRM DIALOG/COMPONENT EDIT
-        ;
-START   N BY,DATA,DDES,DHD,DIC,DNAM,DTYP,FLDS,FR,L,LOGIC,NOW,PNAM,TO,Y
-        N PXRMBG,PXRMHD,PXRMDIEN,PXRMGTYP,PXRMDTYP,PXRMITEM,PXRMMODE,PXRMNAME
-        N PXRMTEMP,PXRMTITL,PXRMVIEW
-        ;Refresh on return
-        S VALMBCK="R"
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Default is display dialog elements
-        S PXRMDTYP="R",PXRMGTYP="DLGR",PXRMVIEW="AN"
-        ;Select dialog for display
-        F  D  Q:'PXRMTEMP
-        .S PXRMTEMP=""
-        .D START^PXRMSEL(.PXRMHD,.PXRMGTYP,"PXRMTEMP") Q:'PXRMTEMP
-        .N X S X="IORESET"
-        .D ENDR^%ZISS,@(PXRMGTYP_"("_PXRMTEMP_")")
-END     Q
-        ;
-        ;Reminder View
-        ;-------------
-DLGR(PXRMITEM)  ;
-        N PXRMDIEN,PXRMCS1,PXRMCS2
-        ;Format headings to include reminder and name
-        S DATA=$G(^PXD(811.9,PXRMITEM,0)),RNAM=$P(DATA,U),PNAM=$P(DATA,U,3)
-        S PXRMHD="REMINDER NAME: "_RNAM
-        ;
-        ;Dialog History
-        F  D  Q:'PXRMDIEN
-        .D START^PXRMDLGH(PXRMITEM,.PXRMDIEN,"PXRMDIEN") Q:'PXRMDIEN
-        .N PXRMHD,VALMBCK,VALMBG,VALMSG,VIEW,X,XMZ
-        .S DNAM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
-        .I $P($G(^PXRMD(801.41,PXRMDIEN,0)),U,3)]"" S DNAM=DNAM_" (DISABLED)"
-        .S PXRMHD="REMINDER DIALOG NAME: "_DNAM
-        .S PXRMCS1=$$FILE^PXRMEXCS(801.41,PXRMDIEN)
-        .S X="IORESET"
-        .D ENDR^%ZISS,EN^VALM("PXRM DIALOG LIST")
-        .I PXRMDIEN,$D(^PXRMD(801.41,PXRMDIEN,0)) D
-        ..S PXRMCS2=$$FILE^PXRMEXCS(801.41,PXRMDIEN) Q:+PXRMCS2=0
-        ..Q:PXRMCS1=PXRMCS2
-        ..D SEHIST^PXRMUTIL(801.41,"^PXRMD(801,41,",PXRMDIEN)
-        .W IORESET
-        .D KILL^%ZISS
-        Q
-        ;
-        ;Edit element/prompt/group
-        ;-------------------------
-DLGE(PXRMDIEN)  ;
-        N LOCK,LFIND
-        ;Check for Uneditable flag
-        S LOCK=$P($G(^PXRMD(801.41,PXRMTEMP,100)),U,4)
-        S LFIND=$P($G(^PXRMD(801.41,PXRMTEMP,1)),U,5)
-        I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST) D  Q
-        .W !,"This item can not be edited" H 2
-        ;
-        S PXRMHD="Dialog Name: ",PXRMDIEN=PXRMTEMP
-        ;Format headings to include dialog name
-        S DATA=$G(^PXRMD(801.41,PXRMDIEN,0)),DDES=$P(DATA,U),DTYP=$P(DATA,U,4)
-        ;Test
-        I DTYP="G" D DLG(PXRMDIEN) Q
-        ;
-        S PXRMHD=PXRMHD_" "_DDES W PXRMHD,!
-        ;Edit selected dialog
-        D EDIT^PXRMDEDT(DTYP,PXRMDIEN,0)
-        Q
-        ;
-        ;Reminder dialog view
-        ;--------------------
-DLG(PXRMDIEN)   ;
-        S PXRMDIEN=PXRMTEMP
-        S PXRMNAME=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
-        S PXRMITEM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U,2)
-        ;Format headings to include dialog name
-        S PXRMHD=PXRMHD_PXRMNAME
-        ;Check if the set is disable and add to header if disabled
-        I $P(^PXRMD(801.41,PXRMDIEN,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
-        ;Listman option
-        D EN^VALM("PXRM DIALOG LIST")
-        W IORESET
-        D KILL^%ZISS
-        Q
-        ;
-        ;Other subroutines
-        ;
-        ;Ask update or no
-        ;----------------
-ASK(YESNO)      ;
-        N X,Y,TEXT,DIR
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="YA0"
-        S DIR("A")="LINK THIS REMINDER TO DIALOG - "_$P(PXRMHD,": ",2)_": "
-        S DIR("B")="Y"
-        S DIR("?")="Enter Y or N. For detailed help type ??"
-        S DIR("??")=U_"D HLP^PXRMDLGY(1)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        S YESNO=$E(Y(0))
-        Q
-        ;
-        ;Display dialogs autogenerated from this reminder
-        ;------------------------------------------------
-DISP(RIEN)      ;
-        N ARRAY,DSUB,FIRST
-        ;Get OTHER dialogs
-        S FIRST=1,DSUB=""
-        F  S DSUB=$O(^PXRMD(801.41,"AG",RIEN,DSUB)) Q:'DSUB  D
-        .W !
-        .D:FIRST
-        ..W "DIALOGS ALREADY GENERATED FROM THIS REMINDER:",!! S FIRST=0
-        .W ?20,$P($G(^PXRMD(801.41,DSUB,0)),U)
-        ;
-        I 'FIRST W !
-        ;
-        Q
-        ;
-        ;Display linked reminders
-        ;------------------------
-DISPL(DIEN)     ;
-        N ARRAY,DLG,RSUB,FIRST,RNAM
-        S RSUB=$P($G(^PXRMD(801.41,DIEN,0)),U,2)
-        I RSUB W !!,"SOURCE REMINDER: "_$P($G(^PXD(811.9,RSUB,0)),U)
-        ;Linked reminders
-        S FIRST=1,RNAM=""
-        F  S RNAM=$O(^PXD(811.9,"B",RNAM)) Q:RNAM=""  D
-        .S RSUB=$O(^PXD(811.9,"B",RNAM,"")) Q:'RSUB
-        .S DLG=$P($G(^PXD(811.9,RSUB,51)),U) Q:DLG'=DIEN
-        .W ! I FIRST W !,"REMINDERS ALREADY LINKED TO THIS DIALOG:",!! S FIRST=0
-        .W ?18,$P($G(^PXD(811.9,RSUB,0)),U)
-        Q
-        ;
-        ;Link a dialog (called by protocol PXRM DIALOG/REMINDER LINK)
-        ;-------------
-LINK(DIEN)      ;
-        F  D  Q:$D(DTOUT)!$D(DUOUT)
-        .W IORESET
-        .S VALMBCK="R"
-        .;Display linked reminders
-        .D DISPL(DIEN)
-        .;
-        .N ANS,DIC,DIR,DLG,LIT1,PNAME,PXRMREM,REM
-        .S DIC("A")="SELECT A REMINDER TO LINK OR CHANGE: "
-        .S LIT1="You must select a reminder!"
-        .D SEL(811.9,"AEQMZ",.PXRMREM)
-        .Q:$D(DTOUT)!$D(DUOUT)
-        .S REM=$P(PXRMREM(1),U),PNAME=$P(PXRMREM(1),U,3)
-        .I PNAME]"" W !!,"REMINDER PRINT NAME: "_PNAME,!
-        .;Display related dialogs
-        .D DISP(REM)
-        .;Check if already linked
-        .S DLG=$P($G(^PXD(811.9,REM,51)),U)
-        .;Reconfirm to link reminder
-        .I 'DLG S ANS="" D ASK(.ANS) Q:ANS'="Y"
-        .;
-        .N DA,DR,DIE
-        .;Edit selected reminder
-        .S DA=REM
-        .;Settup local variables
-        .S DIE="^PXD(811.9,",DR=51
-        .;If no link force entry
-        .I 'DLG S DR=DR_"///"_PXRMNAME
-        .D ^DIE
-        Q
-        ;
-        ;Link a Reminder (called by protocol PXRM DIALOG LINK)
-        ;---------------
-RLINK(REM)      ;
-        N DLG
-        ;Re-display reminder name
-        W IORESET
-        W !,PXRMHD
-        ;
-        N DA,DR,DIE
-        ;Edit selected reminder
-        S DA=REM
-        ;Settup local variables
-        S DIE="^PXD(811.9,",DR=51
-        ;If no link force entry
-        D ^DIE
-        Q
-        ;
-        ;General help text routine.
-        ;--------------------------
-HLP(CALL)       ;
-        N HTEXT
-        N DIWF,DIWL,DIWR,IC
-        S DIWF="C75",DIWL=0,DIWR=75
-        ;
-        I CALL=1 D
-        .S HTEXT(1)="Enter Yes to link reminder to this dialog."
-        I CALL=2 D
-        .S HTEXT(1)="Enter Yes to link reminder to this dialog."
-        K ^UTILITY($J,"W")
-        S IC=""
-        F  S IC=$O(HTEXT(IC)) Q:IC=""  D
-        . S X=HTEXT(IC)
-        . D ^DIWP
-        W !
-        S IC=0
-        F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
-        . W !,^UTILITY($J,"W",0,IC,0)
-        K ^UTILITY($J,"W")
-        W !
-        Q
-        ;
-        ;Reminder selection
-        ;------------------
-SEL(FILE,MODE,ARRAY)    ;
-        N X,Y,CNT
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S CNT=0
-        W !
-        F  D  Q:$D(DTOUT)  Q:$D(DUOUT)  Q:CNT>0  Q:(Y=-1)&(CNT>0)
-        .S DIC=FILE,DIC(0)=MODE
-        .D ^DIC
-        .I X=(U_U) S DTOUT=1
-        .I '$D(DTOUT),('$D(DUOUT)) D
-        ..I +Y'=-1 D  Q
-        ...S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
-        ..W:CNT=0 !,LIT1
-        .K DIC
-        Q
-        ;
-        ;Input transform for FINDING ITEM in 801.41
-XINP(X) ;Taxonomy findings are not allowed for dialog groups
-        I $P(X,";",2)="PXD(811.2,",$P($G(^PXRMD(801.41,DA,0)),U,4)="G" D  Q 0
-        .W $C(7),!,"A taxonomy cannot be entered as the finding item for a group"
-        ;Only applies to MH
-        I $P(X,";",2)'="^YTT(601.71," Q 1
-        I $$OK^PXRMDLL($P(X,";")) Q 1
-        W *7,!,"This test is not appropriate for the GUI",!
-        Q 0
+PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;05/31/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Called by option PXRM DIALOG/COMPONENT EDIT
+ ;
+START N BY,DATA,DDES,DHD,DIC,DNAM,DTYP,FLDS,FR,L,LOGIC,NOW,PNAM,TO,Y
+ N PXRMBG,PXRMHD,PXRMDIEN,PXRMGTYP,PXRMDTYP,PXRMITEM,PXRMMODE,PXRMNAME
+ N PXRMTEMP,PXRMTITL,PXRMVIEW
+ ;Refresh on return
+ S VALMBCK="R"
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Default is display dialog elements
+ S PXRMDTYP="R",PXRMGTYP="DLGR",PXRMVIEW="AN"
+ ;Select dialog for display
+ F  D  Q:'PXRMTEMP
+ .S PXRMTEMP=""
+ .D START^PXRMSEL(.PXRMHD,.PXRMGTYP,"PXRMTEMP") Q:'PXRMTEMP
+ .N X S X="IORESET"
+ .D ENDR^%ZISS,@(PXRMGTYP_"("_PXRMTEMP_")")
+END Q
+ ;
+ ;Reminder View
+ ;-------------
+DLGR(PXRMITEM) ;
+ N PXRMDIEN,PXRMCS1,PXRMCS2
+ ;Format headings to include reminder and name
+ S DATA=$G(^PXD(811.9,PXRMITEM,0)),RNAM=$P(DATA,U),PNAM=$P(DATA,U,3)
+ S PXRMHD="REMINDER NAME: "_RNAM
+ ;
+ ;Dialog History
+ F  D  Q:'PXRMDIEN
+ .D START^PXRMDLGH(PXRMITEM,.PXRMDIEN,"PXRMDIEN") Q:'PXRMDIEN
+ .N PXRMHD,VALMBCK,VALMBG,VALMSG,VIEW,X,XMZ
+ .S DNAM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
+ .I $P($G(^PXRMD(801.41,PXRMDIEN,0)),U,3)]"" S DNAM=DNAM_" (DISABLED)"
+ .S PXRMHD="REMINDER DIALOG NAME: "_DNAM
+ .S PXRMCS1=$$FILE^PXRMEXCS(801.41,PXRMDIEN)
+ .S X="IORESET"
+ .D ENDR^%ZISS,EN^VALM("PXRM DIALOG LIST")
+ .I PXRMDIEN,$D(^PXRMD(801.41,PXRMDIEN,0)) D
+ ..S PXRMCS2=$$FILE^PXRMEXCS(801.41,PXRMDIEN) Q:+PXRMCS2=0
+ ..Q:PXRMCS1=PXRMCS2
+ ..D SEHIST^PXRMUTIL(801.41,"^PXRMD(801,41,",PXRMDIEN)
+ .W IORESET
+ .D KILL^%ZISS
+ Q
+ ;
+ ;Edit element/prompt/group
+ ;-------------------------
+DLGE(PXRMDIEN) ;
+ N LOCK,LFIND
+ ;Check for Uneditable flag
+ S LOCK=$P($G(^PXRMD(801.41,PXRMTEMP,100)),U,4)
+ S LFIND=$P($G(^PXRMD(801.41,PXRMTEMP,1)),U,5)
+ I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST) D  Q
+ .W !,"This item can not be edited" H 2
+ ;
+ S PXRMHD="Dialog Name: ",PXRMDIEN=PXRMTEMP
+ ;Format headings to include dialog name
+ S DATA=$G(^PXRMD(801.41,PXRMDIEN,0)),DDES=$P(DATA,U),DTYP=$P(DATA,U,4)
+ ;Test
+ I DTYP="G" D DLG(PXRMDIEN) Q
+ ;
+ S PXRMHD=PXRMHD_" "_DDES W PXRMHD,!
+ ;Edit selected dialog
+ D EDIT^PXRMDEDT(DTYP,PXRMDIEN,0)
+ Q
+ ;
+ ;Reminder dialog view
+ ;--------------------
+DLG(PXRMDIEN) ;
+ S PXRMDIEN=PXRMTEMP
+ S PXRMNAME=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U)
+ S PXRMITEM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U,2)
+ ;Format headings to include dialog name
+ S PXRMHD=PXRMHD_PXRMNAME
+ ;Check if the set is disable and add to header if disabled
+ I $P(^PXRMD(801.41,PXRMDIEN,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)"
+ ;Listman option
+ D EN^VALM("PXRM DIALOG LIST")
+ W IORESET
+ D KILL^%ZISS
+ Q
+ ;
+ ;Other subroutines
+ ;
+ ;Ask update or no
+ ;----------------
+ASK(YESNO) ;
+ N X,Y,TEXT,DIR
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="YA0"
+ S DIR("A")="LINK THIS REMINDER TO DIALOG - "_$P(PXRMHD,": ",2)_": "
+ S DIR("B")="Y"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ S DIR("??")=U_"D HLP^PXRMDLGY(1)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ S YESNO=$E(Y(0))
+ Q
+ ;
+ ;Display dialogs autogenerated from this reminder
+ ;------------------------------------------------
+DISP(RIEN) ;
+ N ARRAY,DSUB,FIRST
+ ;Get OTHER dialogs
+ S FIRST=1,DSUB=""
+ F  S DSUB=$O(^PXRMD(801.41,"AG",RIEN,DSUB)) Q:'DSUB  D
+ .W !
+ .D:FIRST
+ ..W "DIALOGS ALREADY GENERATED FROM THIS REMINDER:",!! S FIRST=0
+ .W ?20,$P($G(^PXRMD(801.41,DSUB,0)),U)
+ ;
+ I 'FIRST W !
+ ;
+ Q
+ ;
+ ;Display linked reminders
+ ;------------------------
+DISPL(DIEN) ;
+ N ARRAY,DLG,RSUB,FIRST,RNAM
+ S RSUB=$P($G(^PXRMD(801.41,DIEN,0)),U,2)
+ I RSUB W !!,"SOURCE REMINDER: "_$P($G(^PXD(811.9,RSUB,0)),U)
+ ;Linked reminders
+ S FIRST=1,RNAM=""
+ F  S RNAM=$O(^PXD(811.9,"B",RNAM)) Q:RNAM=""  D
+ .S RSUB=$O(^PXD(811.9,"B",RNAM,"")) Q:'RSUB
+ .S DLG=$P($G(^PXD(811.9,RSUB,51)),U) Q:DLG'=DIEN
+ .W ! I FIRST W !,"REMINDERS ALREADY LINKED TO THIS DIALOG:",!! S FIRST=0
+ .W ?18,$P($G(^PXD(811.9,RSUB,0)),U)
+ Q
+ ;
+ ;Link a dialog (called by protocol PXRM DIALOG/REMINDER LINK)
+ ;-------------
+LINK(DIEN) ;
+ F  D  Q:$D(DTOUT)!$D(DUOUT)
+ .W IORESET
+ .S VALMBCK="R"
+ .;Display linked reminders
+ .D DISPL(DIEN)
+ .;
+ .N ANS,DIC,DIR,DLG,LIT1,PNAME,PXRMREM,REM
+ .S DIC("A")="SELECT A REMINDER TO LINK OR CHANGE: "
+ .S LIT1="You must select a reminder!"
+ .D SEL(811.9,"AEQMZ",.PXRMREM)
+ .Q:$D(DTOUT)!$D(DUOUT)
+ .S REM=$P(PXRMREM(1),U),PNAME=$P(PXRMREM(1),U,3)
+ .I PNAME]"" W !!,"REMINDER PRINT NAME: "_PNAME,!
+ .;Display related dialogs
+ .D DISP(REM)
+ .;Check if already linked
+ .S DLG=$P($G(^PXD(811.9,REM,51)),U)
+ .;Reconfirm to link reminder
+ .I 'DLG S ANS="" D ASK(.ANS) Q:ANS'="Y"
+ .;
+ .N DA,DR,DIE
+ .;Edit selected reminder
+ .S DA=REM
+ .;Settup local variables
+ .S DIE="^PXD(811.9,",DR=51
+ .;If no link force entry
+ .I 'DLG S DR=DR_"///"_PXRMNAME
+ .D ^DIE
+ Q
+ ;
+ ;Link a Reminder (called by protocol PXRM DIALOG LINK)
+ ;---------------
+RLINK(REM) ;
+ N DLG
+ ;Re-display reminder name
+ W IORESET
+ W !,PXRMHD
+ ;
+ N DA,DR,DIE
+ ;Edit selected reminder
+ S DA=REM
+ ;Settup local variables
+ S DIE="^PXD(811.9,",DR=51
+ ;If no link force entry
+ D ^DIE
+ Q
+ ;
+ ;General help text routine.
+ ;--------------------------
+HLP(CALL) ;
+ N HTEXT
+ N DIWF,DIWL,DIWR,IC
+ S DIWF="C75",DIWL=0,DIWR=75
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="Enter Yes to link reminder to this dialog."
+ I CALL=2 D
+ .S HTEXT(1)="Enter Yes to link reminder to this dialog."
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
+ W !
+ Q
+ ;
+ ;Reminder selection
+ ;------------------
+SEL(FILE,MODE,ARRAY) ;
+ N X,Y,CNT
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S CNT=0
+ W !
+ F  D  Q:$D(DTOUT)  Q:$D(DUOUT)  Q:CNT>0  Q:(Y=-1)&(CNT>0)
+ .S DIC=FILE,DIC(0)=MODE
+ .D ^DIC
+ .I X=(U_U) S DTOUT=1
+ .I '$D(DTOUT),('$D(DUOUT)) D
+ ..I +Y'=-1 D  Q
+ ...S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
+ ..W:CNT=0 !,LIT1
+ .K DIC
+ Q
+ ;
+ ;Input transform for FINDING ITEM in 801.41
+XINP(X) ;Taxonomy findings are not allowed for dialog groups
+ I $P(X,";",2)="PXD(811.2,",$P($G(^PXRMD(801.41,DA,0)),U,4)="G" D  Q 0
+ .W $C(7),!,"A taxonomy cannot be entered as the finding item for a group"
+ ;Only applies to MH
+ I $P(X,";",2)'="YTT(601," Q 1
+ ;GAF
+ I $P($G(^YTT(601,$P(X,";"),0)),U)="GAF" Q 1
+ ;Check if a VALID GUI test
+ I $P($G(^YTT(601.6,$P(X,";"),0)),U,4)="Y" Q 1
+ ;else
+ W *7,!,"This test is not appropriate for the GUI",!
+ Q 0

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m

@@ -1 @@
-PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007
-        ;;2.0;CLINICAL REMINDERS;**10,6**;Feb 04, 2005;Build 123
-        ;
-OK(DIEN)        ;Check if mental health test is for GUI
-        I 'DIEN Q 0
-        Q $$MH^PXRMDLG5(DIEN)
-        ;
-TXT     ;Format text
-        N NULL
-        S TEXT=DTXT(SUB),NULL=0
-        I ($E(TEXT)=" ")!(TEXT="") S NULL=1
-        I LAST,'NULL S TEXT="<br>"_TEXT
-        S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
-        S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
-        Q
-        ; 
-EXP(TIEN,DITEM,DSUB)    ;Expand taxonomy codes
-        N ACNT,AHIS,ATYP,ARRAY,CODES,CNT,DPCE,DTAX
-        ;Get taxonomy file details
-        D TAX(TIEN,.ARRAY)
-        ;
-        ;Build dialog from the returned array
-        ;
-        ;Main Taxonomy prompt
-        S DTXT=ARRAY
-        S OCNT=OCNT+1
-        S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC
-        ;Default group indents and selection entry
-        S $P(ORY(OCNT),U,16)=2,$P(ORY(OCNT),U,18)=2
-        S OCNT=OCNT+1
-        S ORY(OCNT)=2_U_DITEM_U_DSUB_U_DTXT
-        ;
-        ;Taxonomy CPT/POV resolution prompts
-        S ACNT=""
-        F  S ACNT=$O(ARRAY(ACNT)) Q:ACNT=""  D
-        .;Prompt text
-        .S DTXT=$P(ARRAY(ACNT),U),DPCE=$P(ARRAY(ACNT),U,4)
-        .;Historical/Current flag
-        .S AHIS=0 I $P(ARRAY(ACNT),U,3)=2 S AHIS=1
-        .;CPT/POV
-        .S ATYP="POV" I $P(ARRAY(ACNT),U,2)=81 S ATYP="CPT"
-        .;Initial display
-        .S DHIDE=0,DCHECK=0,DDIS=0
-        .;Construct ien for this level
-        .S DTAX=DSUB_"."_ACNT
-        .S OCNT=OCNT+1
-        .S ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS
-        .S OCNT=OCNT+1
-        .S ORY(OCNT)=2_U_DITEM_U_DTAX_U_DTXT
-        Q
-        ;
-GROUP(DIEN,DSUB)        ;Dialog group
-        N DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND
-        N DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT
-        ;Group caption text
-        S DATA=$G(^PXRMD(801.41,DIEN,0))
-        S DCAP=$P(DATA,U,5),DBOX=$P(DATA,U,6),DIND=$P(DATA,U,7)
-        S DSHARE=$P(DATA,U,8),DENTRY=$P(DATA,U,9),DHIDE=$P(DATA,U,10)
-        S DINDPN=$P(DATA,U,12) S:DINDPN="" DINDPN=0
-        S DBOX=$S(DBOX="Y":1,1:"")
-        ;group header is display only if SUPPRESS CHECKBOX
-        S DCHK="S" I ('DHIDE)&(DSUPP) S DCHK="D",DHIDE=0
-        ;Default group setting to hide
-        I DHIDE="" S DHIDE=1
-        ;
-        S DEXC=$P($G(^PXRMD(801.41,DIEN,2)),U,3)
-        ;
-        S OCNT=OCNT+1,ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC
-        S $P(ORY(OCNT),U,8)=$$AHIS(DIEN)
-        S $P(ORY(OCNT),U,15)=DHIDE,$P(ORY(OCNT),U,16)=DIND
-        S $P(ORY(OCNT),U,17)=DSHARE,$P(ORY(OCNT),U,18)=DENTRY
-        S $P(ORY(OCNT),U,19)=DBOX,$P(ORY(OCNT),U,20)=DCAP
-        S $P(ORY(OCNT),U,21)=DINDPN
-        ;Create type 2 records if if here is additional group text
-        N LAST,TEXT
-        S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D
-        .D TXT
-        .S OCNT=OCNT+1,ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT
-        ;Get dialog group sub-elements
-        N DTYP,DSUPP,DDIS,IDENT S DGSEQ=0
-        F  S DGSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ)) Q:'DGSEQ  D
-        .S DGSUB=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ,"")) Q:'DGSUB
-        .S DATA=$G(^PXRMD(801.41,DIEN,10,DGSUB,0))
-        .S DGIEN=$P(DATA,U,2) Q:'DGIEN
-        .;Branching logic call to determine if element should be suppress,
-        .;replace or left as is
-        .N TERMNODE,TERMSTAT
-        .S TERMNODE=$G(^PXRMD(801.41,DGIEN,49))
-        .I $G(TERMNODE)'="" D  Q:TERMSTAT=0
-        ..S TERMSTAT=1
-        ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT)
-        .;Exclude from P/N
-        .S DEXC=$P(DATA,U,8)
-        .I $P($G(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR" D
-        ..K DTXT S SUB=0 F  S SUB=$O(^PXRMD(801.41,DGIEN,25,SUB)) Q:'SUB  D
-        ...S DTXT(SUB)=$G(^PXRMD(801.41,DGIEN,25,SUB,0))
-        .;Check if element is disabled/invalid
-        .S DATA=$G(^PXRMD(801.41,DGIEN,0)) Q:DATA=""  Q:$P(DATA,U,3)]""
-        .;If the actual element is exclude from P/N override
-        .I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1
-        .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP
-        .S DMHEX=$P(DATA,U,14)
-        .S DRESL=$$RESGROUP^PXRMDLLB(DGIEN)
-        .;S DRESL=$P(DATA,U,15)
-        .S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)
-        .;Done Elsewhere (historical)
-        .S DHIS=$$AHIS(DGIEN)
-        .S DFIND=$P($G(^PXRMD(801.41,DGIEN,1)),U,5)
-        .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
-        .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
-        .;If mental Health ignore if not GUI
-        .I DPCE="MH" Q:'$$OK(DFIEN)
-        .S DGRP=DSUB_"."_DGSUB
-        .;Taxonomy codes need expanding
-        .I DPCE="T" D EXP(DFIEN,DGIEN,DGRP) Q
-        .;Translate vitals ien to PCE code - This will need a DBIA
-        .I DPCE="VIT" S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
-        .;Embedded Dialog Group
-        .I DTYP="G" D GROUP(DGIEN,DGRP) Q
-        .S DDIS="S" I DSUPP=1 S DDIS="D"
-        .S DGRP=DSUB_"."_DGSUB,OCNT=OCNT+1
-        .S ORY(OCNT)=1_U_DGIEN_U_DGRP_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL_U_$G(DCOUNT)
-        .;
-        .N LAST,TEXT
-        .S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D
-        ..D TXT
-        ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DGIEN_U_DGRP_U_TEXT
-        Q
-        ;
-LOAD(DIEN,DFN)  ;Load dialog questions into array
-        N DARRAY,DATA,DITEM,DFIND,DFIEN,DFTYP,DPCE,DRES,DSEQ,DSUB,DTXT,DTYP,OCNT
-        N DDIS,DEXC,DHIDE,DCHECK,DDIS,DHIS,DMHEX,DRESL,DSUPP,SUB,IDENT,TXTCNT
-        ;Check Status of dialog
-        S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA=""
-        ;If disabled ignore
-        I $P(DATA,U,3)]"" Q
-        ;Ignore if not a reminder dialog
-        I $P(DATA,U,4)'="R" Q
-        ;
-        ;List of PCE codes
-        S DARRAY("AUTTEDT(")="PED"
-        S DARRAY("AUTTEXAM(")="XAM"
-        S DARRAY("AUTTHF(")="HF"
-        S DARRAY("AUTTIMM(")="IMM"
-        S DARRAY("AUTTSK(")="SK"
-        S DARRAY("GMRD(120.51,")="VIT"
-        S DARRAY("ORD(101.41,")="Q"
-        S DARRAY("YTT(601.71,")="MH"
-        S DARRAY("ICD9(")="POV"
-        S DARRAY("ICPT(")="CPT"
-        S DARRAY("PXD(811.2,")="T"
-        S DARRAY("WV(790.1,")="WHR"
-        ;
-        ;Get elements for the dialog
-        S DSEQ=0,OCNT=0
-        F  S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ  D
-        .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
-        .S DATA=$G(^PXRMD(801.41,DIEN,10,DSUB,0))
-        .S DITEM=$P(DATA,U,2) Q:DITEM=""
-        .;Ignore disabled elements
-        .S DATA=$G(^PXRMD(801.41,DITEM,0)) Q:DATA=""  Q:$P(DATA,U,3)]""
-        .;Branching logic call to determine if element should be suppress,
-        .;replace or left as is
-        .S TERMNODE=$G(^PXRMD(801.41,DITEM,49))
-        .N TERMSTAT
-        .I $G(TERMNODE)'="" D  Q:TERMSTAT=0
-        ..S TERMSTAT=1
-        ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)
-        .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)
-        .S DMHEX=$P(DATA,U,14)
-        .S DRESL=$$RESGROUP^PXRMDLLB(DITEM)
-        .;S DRESL=$P(DATA,U,15)
-        .K DTXT S SUB=0
-        .F  S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB  D
-        ..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0))
-        .S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
-        .S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
-        .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
-        .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
-        .;If mental Health ignore if not GUI
-        .I DPCE="MH" Q:'$$OK(DFIEN)
-        .;Exclude from PN
-        .S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
-        .;Taxonomy codes need expanding
-        .I DPCE="T" D EXP(DFIEN,DITEM,DSUB) Q
-        .;Translate vitals ien to PCE code - This will need a DBIA
-        .I DPCE="VIT" S DFIEN=$P($G(^GMRD(120.51,DFIEN,0)),U,7)
-        .;Done Elsewhere (historical)
-        .S DHIS=$$AHIS(DITEM)
-        .;Dialog Group
-        .I DTYP="G" D GROUP(DITEM,DSUB) Q
-        .;Dialog type/text and resolution 
-        .S OCNT=OCNT+1,DDIS="S"
-        .I DSUPP=1 S DDIS="D"
-        .S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL
-        .N LAST,TEXT
-        .S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D
-        ..D TXT
-        ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT
-        Q
-        ;
-TAX(TXIEN,ARRAY)        ;Return list of resolutions/codes for taxonomy
-        N CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP
-        N TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT
-        ;
-        ;Get taxonomy name
-        S TNAME=$P($G(^PXD(811.2,TXIEN,0)),U,1)
-        ;
-        ;Check what type of taxonomy codes exist
-        S TDX=$$TOK^PXRMDLLA(TXIEN,"SDX")
-        S TPR=$$TOK^PXRMDLLA(TXIEN,"SPR")
-        ;
-        ;Taxonomy dialog text
-        S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,3)
-        ;default to taxonomy description if null
-        I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,2)
-        ;default to taxonomy name if null
-        I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,1)
-        ;
-        S CNT=0,ARRAY=DTXT
-        ;
-        ;Diagnoses
-        I TDX D
-        .;Diagnosis texts
-        .S TPAR=$G(^PXD(811.2,TXIEN,"SDZ"))
-        .;Get parameter file node for this finding type
-        .S FNODE=$O(^PXRMD(801.45,"B","POV","")) Q:FNODE=""
-        .;check if finding parameters are disabled
-        .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
-        .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
-        .;get category text (diagnoses)
-        .I 'TCUR D  ; Current
-        ..S TDTXT=$P(TPAR,U,2) S:TDTXT="" TDTXT=TNAME
-        ..S CNT=CNT+1,ARRAY(CNT)=TDTXT_U_80_U_1_U_"POV"
-        .I 'THIS D  ; Historical
-        ..S TDHTXT=$P(TPAR,U,3) S:TDHTXT="" TDHTXT=TNAME_" (HISTORICAL)"
-        ..S CNT=CNT+1,ARRAY(CNT)=TDHTXT_U_80_U_2_U_"POV"
-        ;Procedures
-        I TPR D
-        .;Procedure texts
-        .S TPAR=$G(^PXD(811.2,TXIEN,"SPZ"))
-        .;Get parameter file node for this finding type
-        .S FNODE=$O(^PXRMD(801.45,"B","CPT","")) Q:FNODE=""
-        .;check if finding parameters are disabled
-        .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
-        .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
-        .;get category text (procedures)
-        .I 'TCUR D  ; Current
-        ..S TPTXT=$P(TPAR,U,2) S:TPTXT="" TPTXT=TNAME
-        ..S CNT=CNT+1,ARRAY(CNT)=TPTXT_U_81_U_1_U_"CPT"
-        .I 'THIS D  ; Historical
-        ..S TPHTXT=$P(TPAR,U,3) S:TPHTXT="" TPHTXT=TNAME_" (HISTORICAL)"
-        ..S CNT=CNT+1,ARRAY(CNT)=TPHTXT_U_81_U_2_U_"CPT"
-        ;
-        Q
-        ;
-AHIS(DITEM)     ;
-        N RSIEN,RSNAM
-        S RSIEN=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
-        I RSIEN="" Q 0
-        S RSNAM=$P($G(^PXRMD(801.9,RSIEN,0)),U)
-        I RSNAM["DONE ELSEWHERE" Q 1
-        N GUI,PIEN,PFOUND
-        S PIEN=0,PFOUND=0
-        F  S PIEN=$O(^PXRMD(801.41,DITEM,10,"D",PIEN)) Q:'PIEN  D  Q:PFOUND
-        .;Ignore elements and groups
-        .I "EG"[$P($G(^PXRMD(801.41,PIEN,0)),U,4) Q
-        .;GUI Process
-        .S GUI=$P($G(^PXRMD(801.41,PIEN,46)),U) Q:'GUI
-        .;Check if this is PXRM VISIT DATE (or a copy of it)
-        .I $P($G(^PXRMD(801.42,GUI,0)),U)="VST_DATE" S PFOUND=1
-        Q PFOUND
+PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007
+ ;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25
+ ;
+OK(DIEN) ;Check if mental health test is for GUI
+ I 'DFIEN Q 0
+ I $P($G(^YTT(601.6,DFIEN,0)),U,4)="Y" Q 1
+ I $P($G(^YTT(601,DFIEN,0)),U)="GAF" Q 1
+ Q 0
+ ;
+TXT ;Format text
+ N NULL
+ S TEXT=DTXT(SUB),NULL=0
+ I ($E(TEXT)=" ")!(TEXT="") S NULL=1
+ I LAST,'NULL S TEXT="<br>"_TEXT
+ S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
+ S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
+ Q
+ ; 
+EXP(TIEN,DITEM,DSUB) ;Expand taxonomy codes
+ N ACNT,AHIS,ATYP,ARRAY,CODES,CNT,DPCE,DTAX
+ ;Get taxonomy file details
+ D TAX(TIEN,.ARRAY)
+ ;
+ ;Build dialog from the returned array
+ ;
+ ;Main Taxonomy prompt
+ S DTXT=ARRAY
+ S OCNT=OCNT+1
+ S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC
+ ;Default group indents and selection entry
+ S $P(ORY(OCNT),U,16)=2,$P(ORY(OCNT),U,18)=2
+ S OCNT=OCNT+1
+ S ORY(OCNT)=2_U_DITEM_U_DSUB_U_DTXT
+ ;
+ ;Taxonomy CPT/POV resolution prompts
+ S ACNT=""
+ F  S ACNT=$O(ARRAY(ACNT)) Q:ACNT=""  D
+ .;Prompt text
+ .S DTXT=$P(ARRAY(ACNT),U),DPCE=$P(ARRAY(ACNT),U,4)
+ .;Historical/Current flag
+ .S AHIS=0 I $P(ARRAY(ACNT),U,3)=2 S AHIS=1
+ .;CPT/POV
+ .S ATYP="POV" I $P(ARRAY(ACNT),U,2)=81 S ATYP="CPT"
+ .;Initial display
+ .S DHIDE=0,DCHECK=0,DDIS=0
+ .;Construct ien for this level
+ .S DTAX=DSUB_"."_ACNT
+ .S OCNT=OCNT+1
+ .S ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS
+ .S OCNT=OCNT+1
+ .S ORY(OCNT)=2_U_DITEM_U_DTAX_U_DTXT
+ Q
+ ;
+GROUP(DIEN,DSUB) ;Dialog group
+ N DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND
+ N DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT
+ ;Group caption text
+ S DATA=$G(^PXRMD(801.41,DIEN,0))
+ S DCAP=$P(DATA,U,5),DBOX=$P(DATA,U,6),DIND=$P(DATA,U,7)
+ S DSHARE=$P(DATA,U,8),DENTRY=$P(DATA,U,9),DHIDE=$P(DATA,U,10)
+ S DINDPN=$P(DATA,U,12) S:DINDPN="" DINDPN=0
+ S DBOX=$S(DBOX="Y":1,1:"")
+ ;group header is display only if SUPPRESS CHECKBOX
+ S DCHK="S" I ('DHIDE)&(DSUPP) S DCHK="D",DHIDE=0
+ ;Default group setting to hide
+ I DHIDE="" S DHIDE=1
+ ;
+ S DEXC=$P($G(^PXRMD(801.41,DIEN,2)),U,3)
+ ;
+ S OCNT=OCNT+1,ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC
+ S $P(ORY(OCNT),U,8)=$$AHIS(DIEN)
+ S $P(ORY(OCNT),U,15)=DHIDE,$P(ORY(OCNT),U,16)=DIND
+ S $P(ORY(OCNT),U,17)=DSHARE,$P(ORY(OCNT),U,18)=DENTRY
+ S $P(ORY(OCNT),U,19)=DBOX,$P(ORY(OCNT),U,20)=DCAP
+ S $P(ORY(OCNT),U,21)=DINDPN
+ ;Create type 2 records if if here is additional group text
+ N LAST,TEXT
+ S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D
+ .D TXT
+ .S OCNT=OCNT+1,ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT
+ ;Get dialog group sub-elements
+ N DTYP,DSUPP,DDIS,IDENT S DGSEQ=0
+ F  S DGSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ)) Q:'DGSEQ  D
+ .S DGSUB=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ,"")) Q:'DGSUB
+ .S DATA=$G(^PXRMD(801.41,DIEN,10,DGSUB,0))
+ .S DGIEN=$P(DATA,U,2) Q:'DGIEN
+ .;Branching logic call to determine if element should be suppress,
+ .;replace or left as is
+ .N TERMNODE,TERMSTAT
+ .S TERMNODE=$G(^PXRMD(801.41,DGIEN,49))
+ .I $G(TERMNODE)'="" D  Q:TERMSTAT=0
+ ..S TERMSTAT=1
+ ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT)
+ .;Exclude from P/N
+ .S DEXC=$P(DATA,U,8)
+ .I $P($G(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR" D
+ ..K DTXT S SUB=0 F  S SUB=$O(^PXRMD(801.41,DGIEN,25,SUB)) Q:'SUB  D
+ ...S DTXT(SUB)=$G(^PXRMD(801.41,DGIEN,25,SUB,0))
+ .;Check if element is disabled/invalid
+ .S DATA=$G(^PXRMD(801.41,DGIEN,0)) Q:DATA=""  Q:$P(DATA,U,3)]""
+ .;If the actual element is exclude from P/N override
+ .I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1
+ .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP
+ .S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
+ .S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)
+ .;Done Elsewhere (historical)
+ .S DHIS=$$AHIS(DGIEN)
+ .S DFIND=$P($G(^PXRMD(801.41,DGIEN,1)),U,5)
+ .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
+ .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
+ .;If mental Health ignore if not GUI
+ .I DPCE="MH" Q:'$$OK(DFIEN)
+ .S DGRP=DSUB_"."_DGSUB
+ .;Taxonomy codes need expanding
+ .I DPCE="T" D EXP(DFIEN,DGIEN,DGRP) Q
+ .;Translate vitals ien to PCE code - This will need a DBIA
+ .I DPCE="VIT" S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
+ .;Embedded Dialog Group
+ .I DTYP="G" D GROUP(DGIEN,DGRP) Q
+ .S DDIS="S" I DSUPP=1 S DDIS="D"
+ .S DGRP=DSUB_"."_DGSUB,OCNT=OCNT+1
+ .S ORY(OCNT)=1_U_DGIEN_U_DGRP_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL_U_$G(DCOUNT)
+ .;
+ .N LAST,TEXT
+ .S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D
+ ..D TXT
+ ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DGIEN_U_DGRP_U_TEXT
+ Q
+ ;
+LOAD(DIEN,DFN) ;Load dialog questions into array
+ N DARRAY,DATA,DITEM,DFIND,DFIEN,DFTYP,DPCE,DRES,DSEQ,DSUB,DTXT,DTYP,OCNT
+ N DDIS,DEXC,DHIDE,DCHECK,DDIS,DHIS,DMHEX,DRESL,DSUPP,SUB,IDENT,TXTCNT
+ ;Check Status of dialog
+ S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA=""
+ ;If disabled ignore
+ I $P(DATA,U,3)]"" Q
+ ;Ignore if not a reminder dialog
+ I $P(DATA,U,4)'="R" Q
+ ;
+ ;List of PCE codes
+ S DARRAY("AUTTEDT(")="PED"
+ S DARRAY("AUTTEXAM(")="XAM"
+ S DARRAY("AUTTHF(")="HF"
+ S DARRAY("AUTTIMM(")="IMM"
+ S DARRAY("AUTTSK(")="SK"
+ S DARRAY("GMRD(120.51,")="VIT"
+ S DARRAY("ORD(101.41,")="Q"
+ S DARRAY("YTT(601,")="MH"
+ S DARRAY("ICD9(")="POV"
+ S DARRAY("ICPT(")="CPT"
+ S DARRAY("PXD(811.2,")="T"
+ S DARRAY("WV(790.1,")="WHR"
+ ;
+ ;Get elements for the dialog
+ S DSEQ=0,OCNT=0
+ F  S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ  D
+ .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
+ .S DATA=$G(^PXRMD(801.41,DIEN,10,DSUB,0))
+ .S DITEM=$P(DATA,U,2) Q:DITEM=""
+ .;Ignore disabled elements
+ .S DATA=$G(^PXRMD(801.41,DITEM,0)) Q:DATA=""  Q:$P(DATA,U,3)]""
+ .;Branching logic call to determine if element should be suppress,
+ .;replace or left as is
+ .S TERMNODE=$G(^PXRMD(801.41,DITEM,49))
+ .N TERMSTAT
+ .I $G(TERMNODE)'="" D  Q:TERMSTAT=0
+ ..S TERMSTAT=1
+ ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)
+ .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)
+ .S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
+ .K DTXT S SUB=0
+ .F  S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB  D
+ ..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0))
+ .S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
+ .S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
+ .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
+ .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
+ .;If mental Health ignore if not GUI
+ .I DPCE="MH" Q:'$$OK(DFIEN)
+ .;Exclude from PN
+ .S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
+ .;Taxonomy codes need expanding
+ .I DPCE="T" D EXP(DFIEN,DITEM,DSUB) Q
+ .;Translate vitals ien to PCE code - This will need a DBIA
+ .I DPCE="VIT" S DFIEN=$P($G(^GMRD(120.51,DFIEN,0)),U,7)
+ .;Done Elsewhere (historical)
+ .S DHIS=$$AHIS(DITEM)
+ .;Dialog Group
+ .I DTYP="G" D GROUP(DITEM,DSUB) Q
+ .;Dialog type/text and resolution 
+ .S OCNT=OCNT+1,DDIS="S"
+ .I DSUPP=1 S DDIS="D"
+ .S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL
+ .N LAST,TEXT
+ .S SUB=0,LAST=0 F  S SUB=$O(DTXT(SUB)) Q:'SUB  D
+ ..D TXT
+ ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT
+ Q
+ ;
+TAX(TXIEN,ARRAY) ;Return list of resolutions/codes for taxonomy
+ N CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP
+ N TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT
+ ;
+ ;Get taxonomy name
+ S TNAME=$P($G(^PXD(811.2,TXIEN,0)),U,1)
+ ;
+ ;Check what type of taxonomy codes exist
+ S TDX=$$TOK^PXRMDLLA(TXIEN,"SDX")
+ S TPR=$$TOK^PXRMDLLA(TXIEN,"SPR")
+ ;
+ ;Taxonomy dialog text
+ S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,3)
+ ;default to taxonomy description if null
+ I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,2)
+ ;default to taxonomy name if null
+ I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,1)
+ ;
+ S CNT=0,ARRAY=DTXT
+ ;
+ ;Diagnoses
+ I TDX D
+ .;Diagnosis texts
+ .S TPAR=$G(^PXD(811.2,TXIEN,"SDZ"))
+ .;Get parameter file node for this finding type
+ .S FNODE=$O(^PXRMD(801.45,"B","POV","")) Q:FNODE=""
+ .;check if finding parameters are disabled
+ .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
+ .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
+ .;get category text (diagnoses)
+ .I 'TCUR D  ; Current
+ ..S TDTXT=$P(TPAR,U,2) S:TDTXT="" TDTXT=TNAME
+ ..S CNT=CNT+1,ARRAY(CNT)=TDTXT_U_80_U_1_U_"POV"
+ .I 'THIS D  ; Historical
+ ..S TDHTXT=$P(TPAR,U,3) S:TDHTXT="" TDHTXT=TNAME_" (HISTORICAL)"
+ ..S CNT=CNT+1,ARRAY(CNT)=TDHTXT_U_80_U_2_U_"POV"
+ ;Procedures
+ I TPR D
+ .;Procedure texts
+ .S TPAR=$G(^PXD(811.2,TXIEN,"SPZ"))
+ .;Get parameter file node for this finding type
+ .S FNODE=$O(^PXRMD(801.45,"B","CPT","")) Q:FNODE=""
+ .;check if finding parameters are disabled
+ .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2)
+ .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2)
+ .;get category text (procedures)
+ .I 'TCUR D  ; Current
+ ..S TPTXT=$P(TPAR,U,2) S:TPTXT="" TPTXT=TNAME
+ ..S CNT=CNT+1,ARRAY(CNT)=TPTXT_U_81_U_1_U_"CPT"
+ .I 'THIS D  ; Historical
+ ..S TPHTXT=$P(TPAR,U,3) S:TPHTXT="" TPHTXT=TNAME_" (HISTORICAL)"
+ ..S CNT=CNT+1,ARRAY(CNT)=TPHTXT_U_81_U_2_U_"CPT"
+ ;
+ Q
+ ;
+AHIS(DITEM) ;
+ N RSIEN,RSNAM
+ S RSIEN=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
+ I RSIEN="" Q 0
+ S RSNAM=$P($G(^PXRMD(801.9,RSIEN,0)),U)
+ I RSNAM["DONE ELSEWHERE" Q 1
+ N GUI,PIEN,PFOUND
+ S PIEN=0,PFOUND=0
+ F  S PIEN=$O(^PXRMD(801.41,DITEM,10,"D",PIEN)) Q:'PIEN  D  Q:PFOUND
+ .;Ignore elements and groups
+ .I "EG"[$P($G(^PXRMD(801.41,PIEN,0)),U,4) Q
+ .;GUI Process
+ .S GUI=$P($G(^PXRMD(801.41,PIEN,46)),U) Q:'GUI
+ .;Check if this is PXRM VISIT DATE (or a copy of it)
+ .I $P($G(^PXRMD(801.42,GUI,0)),U)="VST_DATE" S PFOUND=1
+ Q PFOUND

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m

@@ -1 @@
-PXRMDLLA        ;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-FREC(DFIEN,DFTYP)       ;Build type 3 record
-        N CSARRAY,CSCNT
-        ;Dialog type/text and resolution  
-        S DNAM=$$NAME(DFIEN,DFTYP)
-        D CODE^PXRMDLLB(DFIEN,DFTYP,.CSARRAY)
-        I $D(CSARRAY)>0 D  Q
-        . S CSCNT="" F  S CSCNT=$O(CSARRAY(CSCNT)) Q:CSCNT=""  D
-        . . S OCNT=OCNT+1
-        . . S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(CSARRAY(CSCNT))_U_DNAM_U_U_DVIT
-        ;Translate vitals ien to PCE code - This will need a DBIA
-        S DCOD=""
-        I DPCE="VIT" D
-        .S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
-        .;Vitals Caption
-        .S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4)
-        I DFTYP]"" D
-        .S OCNT=OCNT+1
-        .S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT
-        .;Get order type for orderable items
-        .;DBIA #3110
-        .S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4)
-        .;If mental health check if a GAF score and if MH test is required
-        .I DPCE="MH",DFIEN D
-        ..;DBIA #5044
-        ..I $P($G(^YTT(601.71,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
-        ..;Check to see if the MH test is required
-        ..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,0)),U,18)
-        ..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
-        Q
-        ;
-GUI(IEN)        ;Work out prompt type for PCE
-        Q:IEN="" ""
-        N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U)
-        Q:'SUB ""
-        Q $P($G(^PXRMD(801.42,SUB,0)),U)
-        ;
-LOAD(DITEM,DCUR,DTTYP)  ;Load dialog questions into array
-        N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
-        N DVIT,NODE,CNT,IDENT
-        ;DBIA #3110    OR(101.41
-        ;
-        ;Build list of PCE codes
-        S DARRAY("AUTTEDT(")="PED"
-        S DARRAY("AUTTEXAM(")="XAM"
-        S DARRAY("AUTTHF(")="HF"
-        S DARRAY("AUTTIMM(")="IMM"
-        S DARRAY("AUTTSK(")="SK"
-        ;
-        S DARRAY("GMRD(120.51,")="VIT"
-        S DARRAY("ORD(101.41,")="Q"
-        S DARRAY("YTT(601.71,")="MH"
-        ;
-        S DARRAY("ICD9(")="POV"
-        S DARRAY("ICPT(")="CPT"
-        S DARRAY("WV(790.404,")="WH"
-        S DARRAY("WV(790.1,")="WHR"
-        ;
-        S DARRAY("PXD(811.2,")="T"
-        ;
-        ;Get the dialog element
-        S OCNT=0
-        N TERMNODE,TERMSTAT,TERMOUT
-        S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4)
-        ;Finding detail
-        S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
-        S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
-        ;check for WH finding
-        I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND)
-        ;
-        S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
-        S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
-        ;Exclude from P/N
-        S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
-        ;
-        ;Non taxonomy codes (3 - finding record)
-        I DPCE'="T" D FREC(DFIEN,DFTYP)
-        ;
-        ;Taxonomy codes need expanding (3 - finding record)
-        I DPCE="T" D EXP^PXRMDLLB(DFIEN,DCUR,DTTYP)
-        ;
-        ;Prompt details (4 - prompt records)
-        N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
-        ;If not a taxonomy get prompts from dialog file
-        I DPCE'="T" D PROTH(DITEM)
-        ;Check for MST findings
-        I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN)
-        ;If taxonomy use finding parameters (CPT/POV)
-        I DPCE="T" D
-        .;Quit if finding type not passed
-        .Q:DTTYP=""
-        .N RSUB,FNODE
-        .;Get parameter file node for this finding type
-        .S FNODE=$O(^PXRMD(801.45,"B",DTTYP,"")) Q:FNODE=""
-        .;Derive resolution from line ien 1=done 2=done elsewhere
-        .S RSUB=DCUR+1 I (RSUB<1)!(RSUB>2) Q
-        .;Get details from 811.5
-        .D PRTAX(FNODE,RSUB)
-        ;Return array of type 4 records
-        S DSEQ=""
-        F  S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ  D
-        .S OCNT=OCNT+1
-        .S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
-        .S DSSEQ=""
-        .F  S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ  D
-        ..S OCNT=OCNT+1
-        ..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
-        ;
-        ;Get progress note text if defined
-        I DPCE'="T" D:'DEXC PTXT(DITEM)
-        ;Additional findings
-        N FASUB
-        S FASUB=0
-        F  S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB  D
-        .S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
-        .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP=""  Q:DFIEN=""
-        .S DVIT="",DPCE=$G(DARRAY(DFTYP))
-        .I DPCE'="" D FREC(DFIEN,DFTYP)
-        Q
-        ;
-        ;
-        ;Returns item name
-NAME(DFIEN,DFTYP)       ;
-        Q:DFTYP="" ""
-        Q:DFIEN="" ""
-        N NAME,FGLOB,POSN
-        ;DBIA #4108
-        I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME
-        I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME
-        S POSN=2
-        S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3
-        S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN)
-        I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U)
-        I NAME="" S NAME=DFIEN
-        Q NAME
-        ;
-PROTH(IEN)      ; Additional prompts defined in 801.41
-        N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
-        N DTXT,DTYP,PRINT
-        S DSEQ=0
-        F  S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ  D
-        .;Get prompts in sequence
-        .S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB
-        .;Prompt ien
-        .S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN
-        .;Ignore disabled components, and those that are not prompts
-        .Q:($P($G(^PXRMD(801.41,DIEN,0)),U,3)]"")!("PF"'[$P($G(^(0)),U,4))
-        .;Set defaults to null
-        .S DDEF="",DEXC="",DREQ="",DSNL=""
-        .;Prompt name and GUI process (quit if null)
-        .S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN)
-        .I $G(DGUI)="WH_NOT_PURP" D
-        ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
-        .;Type Prompt or Forced
-        .S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
-        .I "PF"[DTYP D
-        ..;Required/Prompt caption
-        ..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4)
-        ..;Default value or forced value
-        ..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2)
-        ..;Override caption/start new line/exclude PN from dialog file
-        ..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9)
-        ..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8)
-        ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
-        ..;Convert date to fileman format
-        ..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT()
-        .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT)
-        .;the following section add a comment prompt to the WH review of result
-        .;section of the reminder dialog
-        .I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D
-        ..N WHCNT,WHFLAG,WHNUM,WHLOOP
-        ..S WHNUM=DSEQ+1,WHLOOP=0
-        ..F WHLOOP=0 D
-        ...S (WHCNT,WHFLAG)=0
-        ...F  S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1)  D
-        ....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1
-        ...I WHFLAG=0 S WHLOOP=1
-        ..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
-        .;Additional checkboxes
-        .I DGUI="COM",DIEN>1 D
-        ..N DSSEQ,DSUB,DTEXT
-        ..S DSSEQ=0
-        ..F  S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ  D
-        ...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB
-        ...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT=""
-        ...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
-        Q
-        ;
-PRTAX(FNODE,RSUB)       ;Get all additional fields for this resolution type
-        N ACNT,ASUB
-        N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT
-        S ASUB=0,DSEQ=0
-        F  S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB  D
-        .S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA=""
-        .;Ignore if disabled
-        .I $P(DDATA,U,3)=1 Q
-        .S DSUB=$P(DDATA,U) Q:DDATA=""
-        .S DSEQ=DSEQ+1
-        .;Set defaults to null
-        .S DDEF="",DEXC="",DREQ="",DSNL=""
-        .;Prompt name and GUI process (quit if null)
-        .S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB)
-        .I $G(DGUI)="WH_NOT_PURP" D
-        ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
-        .;Type Prompt or Forced
-        .S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4)
-        .I DTYP="P" D
-        ..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
-        ..;Override caption/start new line/exclude from PN from finding type 
-        ..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7)
-        ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
-        ..;Required/Prompt caption
-        ..S DDATA=$G(^PXRMD(801.41,DSUB,2))
-        .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT)
-        Q
-        ;
-PTXT(ITEM)      ;Get progress note (WP) text for type 6 records
-        N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT
-        S SUB=0
-        F  S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB  D
-        .S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0))
-        S SUB=0,LAST=0 F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D
-        .S TEXT=$G(ARRAY(SUB))
-        .S NULL=0 I (TEXT="")!($E(TEXT)=" ") S NULL=1
-        .I LAST,'NULL S TEXT="<br>"_TEXT
-        .S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
-        .S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
-        .S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT
-        Q
-        ;
-TOK(TIEN,TYPE)  ;Check if selectable codes exist
-        N DATA,FOUND,SUB
-        S FOUND=0,SUB=0
-        F  S SUB=$O(^PXD(811.2,TIEN,TYPE,SUB)) Q:'SUB  D  Q:FOUND
-        .S DATA=$G(^PXD(811.2,TIEN,TYPE,SUB,0)) Q:DATA=""
-        .;Ignore disabled codes
-        .I '$P(DATA,U,3) S FOUND=1
-        Q FOUND
+PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+FREC(DFIEN,DFTYP) ;Build type 3 record
+ N CSARRAY,CSCNT
+ ;Dialog type/text and resolution  
+ S DNAM=$$NAME(DFIEN,DFTYP)
+ D CODE^PXRMDLLB(DFIEN,DFTYP,.CSARRAY)
+ I $D(CSARRAY)>0 D  Q
+ . S CSCNT="" F  S CSCNT=$O(CSARRAY(CSCNT)) Q:CSCNT=""  D
+ . . S OCNT=OCNT+1
+ . . S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(CSARRAY(CSCNT))_U_DNAM_U_U_DVIT
+ ;Translate vitals ien to PCE code - This will need a DBIA
+ S DCOD=""
+ I DPCE="VIT" D
+ .S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
+ .;Vitals Caption
+ .S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4)
+ I DFTYP]"" D
+ .S OCNT=OCNT+1
+ .S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT
+ .;Get order type for orderable items
+ .;DBIA #3110
+ .S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4)
+ .;If mental health check if a GAF score and if MH test is required
+ .I DPCE="MH",DFIEN D
+ ..I $P($G(^YTT(601,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
+ ..;Check to see if the MH test is required
+ ..S $P(ORY(OCNT),U,13)=$S($P($G(^PXRMD(801.41,DITEM,0)),U,18)=1:1,1:0)
+ Q
+ ;
+GUI(IEN) ;Work out prompt type for PCE
+ Q:IEN="" ""
+ N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U)
+ Q:'SUB ""
+ Q $P($G(^PXRMD(801.42,SUB,0)),U)
+ ;
+LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array
+ N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
+ N DVIT,NODE,CNT,IDENT
+ ;DBIA #3110    OR(101.41
+ ;
+ ;Build list of PCE codes
+ S DARRAY("AUTTEDT(")="PED"
+ S DARRAY("AUTTEXAM(")="XAM"
+ S DARRAY("AUTTHF(")="HF"
+ S DARRAY("AUTTIMM(")="IMM"
+ S DARRAY("AUTTSK(")="SK"
+ ;
+ S DARRAY("GMRD(120.51,")="VIT"
+ S DARRAY("ORD(101.41,")="Q"
+ S DARRAY("YTT(601,")="MH"
+ ;
+ S DARRAY("ICD9(")="POV"
+ S DARRAY("ICPT(")="CPT"
+ S DARRAY("WV(790.404,")="WH"
+ S DARRAY("WV(790.1,")="WHR"
+ ;
+ S DARRAY("PXD(811.2,")="T"
+ ;
+ ;Get the dialog element
+ S OCNT=0
+ N TERMNODE,TERMSTAT,TERMOUT
+ S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4)
+ ;Finding detail
+ S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
+ S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
+ ;check for WH finding
+ I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND)
+ ;
+ S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
+ S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
+ ;Exclude from P/N
+ S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
+ ;
+ ;Non taxonomy codes (3 - finding record)
+ I DPCE'="T" D FREC(DFIEN,DFTYP)
+ ;
+ ;Taxonomy codes need expanding (3 - finding record)
+ I DPCE="T" D EXP^PXRMDLLB(DFIEN,DCUR,DTTYP)
+ ;
+ ;Prompt details (4 - prompt records)
+ N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
+ ;If not a taxonomy get prompts from dialog file
+ I DPCE'="T" D PROTH(DITEM)
+ ;Check for MST findings
+ I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN)
+ ;If taxonomy use finding parameters (CPT/POV)
+ I DPCE="T" D
+ .;Quit if finding type not passed
+ .Q:DTTYP=""
+ .N RSUB,FNODE
+ .;Get parameter file node for this finding type
+ .S FNODE=$O(^PXRMD(801.45,"B",DTTYP,"")) Q:FNODE=""
+ .;Derive resolution from line ien 1=done 2=done elsewhere
+ .S RSUB=DCUR+1 I (RSUB<1)!(RSUB>2) Q
+ .;Get details from 811.5
+ .D PRTAX(FNODE,RSUB)
+ ;Return array of type 4 records
+ S DSEQ=""
+ F  S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ  D
+ .S OCNT=OCNT+1
+ .S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
+ .S DSSEQ=""
+ .F  S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ  D
+ ..S OCNT=OCNT+1
+ ..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
+ ;
+ ;Get progress note text if defined
+ I DPCE'="T" D:'DEXC PTXT(DITEM)
+ ;Additional findings
+ N FASUB
+ S FASUB=0
+ F  S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB  D
+ .S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
+ .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP=""  Q:DFIEN=""
+ .S DVIT="",DPCE=$G(DARRAY(DFTYP))
+ .I DPCE'="" D FREC(DFIEN,DFTYP)
+ Q
+ ;
+ ;
+ ;Returns item name
+NAME(DFIEN,DFTYP) ;
+ Q:DFTYP="" ""
+ Q:DFIEN="" ""
+ N NAME,FGLOB,POSN
+ ;DBIA #4108
+ I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME
+ I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME
+ S POSN=2
+ S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3
+ S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN)
+ I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U)
+ I NAME="" S NAME=DFIEN
+ Q NAME
+ ;
+PROTH(IEN) ; Additional prompts defined in 801.41
+ N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
+ N DTXT,DTYP,PRINT
+ S DSEQ=0
+ F  S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ  D
+ .;Get prompts in sequence
+ .S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB
+ .;Prompt ien
+ .S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN
+ .;Ignore disabled components, and those that are not prompts
+ .Q:($P($G(^PXRMD(801.41,DIEN,0)),U,3)]"")!("PF"'[$P($G(^(0)),U,4))
+ .;Set defaults to null
+ .S DDEF="",DEXC="",DREQ="",DSNL=""
+ .;Prompt name and GUI process (quit if null)
+ .S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN)
+ .I $G(DGUI)="WH_NOT_PURP" D
+ ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
+ .;Type Prompt or Forced
+ .S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
+ .I "PF"[DTYP D
+ ..;Required/Prompt caption
+ ..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4)
+ ..;Default value or forced value
+ ..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2)
+ ..;Override caption/start new line/exclude PN from dialog file
+ ..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9)
+ ..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8)
+ ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
+ ..;Convert date to fileman format
+ ..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT()
+ .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT)
+ .;the following section add a comment prompt to the WH review of result
+ .;section of the reminder dialog
+ .I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D
+ ..N WHCNT,WHFLAG,WHNUM,WHLOOP
+ ..S WHNUM=DSEQ+1,WHLOOP=0
+ ..F WHLOOP=0 D
+ ...S (WHCNT,WHFLAG)=0
+ ...F  S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1)  D
+ ....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1
+ ...I WHFLAG=0 S WHLOOP=1
+ ..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
+ .;Additional checkboxes
+ .I DGUI="COM",DIEN>1 D
+ ..N DSSEQ,DSUB,DTEXT
+ ..S DSSEQ=0
+ ..F  S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ  D
+ ...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB
+ ...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT=""
+ ...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
+ Q
+ ;
+PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type
+ N ACNT,ASUB
+ N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT
+ S ASUB=0,DSEQ=0
+ F  S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB  D
+ .S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA=""
+ .;Ignore if disabled
+ .I $P(DDATA,U,3)=1 Q
+ .S DSUB=$P(DDATA,U) Q:DDATA=""
+ .S DSEQ=DSEQ+1
+ .;Set defaults to null
+ .S DDEF="",DEXC="",DREQ="",DSNL=""
+ .;Prompt name and GUI process (quit if null)
+ .S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB)
+ .I $G(DGUI)="WH_NOT_PURP" D
+ ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
+ .;Type Prompt or Forced
+ .S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4)
+ .I DTYP="P" D
+ ..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
+ ..;Override caption/start new line/exclude from PN from finding type 
+ ..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7)
+ ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
+ ..;Required/Prompt caption
+ ..S DDATA=$G(^PXRMD(801.41,DSUB,2))
+ .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT)
+ Q
+ ;
+PTXT(ITEM) ;Get progress note (WP) text for type 6 records
+ N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT
+ S SUB=0
+ F  S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB  D
+ .S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0))
+ S SUB=0,LAST=0 F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D
+ .S TEXT=$G(ARRAY(SUB))
+ .S NULL=0 I (TEXT="")!($E(TEXT)=" ") S NULL=1
+ .I LAST,'NULL S TEXT="<br>"_TEXT
+ .S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
+ .S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
+ .S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT
+ Q
+ ;
+TOK(TIEN,TYPE) ;Check if selectable codes exist
+ N DATA,FOUND,SUB
+ S FOUND=0,SUB=0
+ F  S SUB=$O(^PXD(811.2,TIEN,TYPE,SUB)) Q:'SUB  D  Q:FOUND
+ .S DATA=$G(^PXD(811.2,TIEN,TYPE,SUB,0)) Q:DATA=""
+ .;Ignore disabled codes
+ .I '$P(DATA,U,3) S FOUND=1
+ Q FOUND

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m

@@ -1 @@
-PXRMDLLB        ;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-CODE(DFIEN,DFTYP,ARRAY) ;
-        N ARY,CNT,CNT1
-        I DFTYP["ICD9" S CODE=$P($G(^ICD9(DFIEN,0)),U) D PERIOD^ICDAPIU(CODE,.ARY)
-        I DFTYP["ICPT" S CODE=$P($$CPT^ICPTCOD(DFIEN),U,2) D PERIOD^ICPTAPIU(CODE,.ARY)
-        I $D(ARY)'>0 Q
-        I $P($G(ARY(0)),U,2)'>0 Q
-        S (CNT,CNT1)=0
-        F  S CNT=$O(ARY(CNT)) Q:CNT=""  D
-        . S ARRAY(CNT1)=CODE_":"_CNT_":"_$P($G(ARY(CNT)),U)
-        . S CNT1=CNT1+1
-        Q
-        ;
-CODES(FILE,TXIEN,ARRAY) ;Return selectable codes from taxonomy file
-        N CNT,CODE,CSCNT,DATA,DATES,DISPLAY,IEN,INSTALL,TEMP,TEXT,NODE,SUB
-        S SUB=0,CNT=0,NODE=$S(FILE=80:"SDX",FILE=81:"SPR")
-        F  S SUB=$O(^PXD(811.2,TXIEN,NODE,SUB)) Q:'SUB  D
-        .S DATA=$G(^PXD(811.2,TXIEN,NODE,SUB,0)) Q:DATA=""
-        .;Ignore if disabled
-        .S DISPLAY=""
-        .I $P(DATA,U,3)=1 Q
-        .;Get ien of code
-        .S IEN=$P(DATA,U) Q:IEN=""
-        .;get date ranges and text from period api
-        .K ARY
-        .I FILE=80 S CODE=$P($G(^ICD9(IEN,0)),U)
-        .I FILE=81 S CODE=$P($$CPT^ICPTCOD(IEN),U,2)
-        .S DISPLAY=$P($G(DATA),U,2)
-        .S TEMP=$$CODE^PXRMVAL(CODE,FILE) Q:'$P(TEMP,U)  Q:$P(TEMP,U,9)=1
-        .;Set display text from taxonomy selectable code text
-        .S TEXT=$P(DATA,U,2)
-        .;otherwise use icd9/cpt description
-        .I TEXT="",FILE=80 S TEXT=$P($$ICDDX^ICDCODE(IEN),U,3)
-        .I TEXT="",FILE=81 S TEXT=$P($$CPT^ICPTCOD(IEN),U,3)
-        .I FILE=80 D PERIOD^ICDAPIU(CODE,.ARY)
-        .I FILE=81 D PERIOD^ICPTAPIU(CODE,.ARY)
-        .I $D(ARY)'>0 Q
-        .I $P($G(ARY(0)),U,2)'>0 Q
-        .S CSCNT=0 F  S CSCNT=$O(ARY(CSCNT)) Q:CSCNT=""  D
-        ..S DATES=":"_CSCNT_":"_$P($G(ARY(CSCNT)),U)
-        ..S TEXT=$P($G(ARY(CSCNT)),U,2) I $G(DISPLAY)'="" S TEXT=DISPLAY
-        ..S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_$G(DATES)_U_$G(TEXT)
-        Q
-        ;
-EXP(TIEN,DCUR,DTTYP)    ;Expand taxonomy codes
-        N CODES,CNT,FILE,LIT,CAT
-        S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
-        S LIT="Selectable "_$S(FILE=80:"Diagnoses:",1:"Procedures:")
-        S CAT=$P($G(^PXD(811.2,TIEN,0)),U)
-        ;
-        S OCNT=OCNT+1
-        S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_U_U_U_U_CAT_U_LIT
-        ;Get selectable codes
-        D CODES(FILE,TIEN,.CODES)
-        S CNT=0
-        ;Save selectable codes as type 5 records
-        F  S CNT=$O(CODES(CNT)) Q:'CNT  D
-        .S OCNT=OCNT+1,ORY(OCNT)=5_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
-        Q
-        ;
-        ;Pass MST code as a forced value
-MST(DFTYP,DFIEN)        ;
-        ;Validate finding ien
-        Q:DFIEN=""
-        ;For each MST term check if finding is mapped
-        N FOUND,TCOND,TIEN,TNAM,TSUB
-        S FOUND=0
-        F TNAM="POSITIVE","NEGATIVE","DECLINES" D  Q:FOUND
-        .;Get term IEN
-        .S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN
-        .;Check if finding is mapped to term
-        .Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
-        .;If exam and term condition logic is null ignore
-        .I DFTYP="AUTTEXAM(" D  Q:TCOND=""
-        ..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB
-        ..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
-        .;If it is then create additional prompt for MST
-        .N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
-        .;Add to end of array
-        .S DSEQ=$O(ARRAY(""),-1)+1
-        .;Null fields
-        .S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ=""
-        .;MST status (exept for exams)
-        .I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
-        .;GUI process and forced value
-        .S DGUI="MST",DTYP="F"
-        .;Save in array
-        .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
-        .;Quit after the first term is found
-        .S FOUND=1
-        Q
-        ;
-REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT)       ;
-        ;this section is use to compare the term evalution result against
-        ;the value store in the Reminder Term Status field.
-        ;If the value match and the replacement item is active then the orginal
-        ;item will be replace with the new item.
-        N TERMOUT
-        S TERMSTAT=1 I +$P(TERMNODE,U),$P($G(TERMNODE),U,2)'="" D  Q:+TERMSTAT=0
-        .N DITEMO
-        .S TERMOUT=$$TERM($P(TERMNODE,U),DFN,$G(DITEM))
-        .I TERMOUT'=$P(TERMNODE,U,2) Q
-        .I +$P(TERMNODE,U,3)'>0 S TERMSTAT=0 Q
-        .S DITEMO=DITEM,DITEM=$P(TERMNODE,U,3),DATA=$G(^PXRMD(801.41,DITEM,0))
-        .I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q
-        Q
-        ;
-RESGROUP(DIEN)  ;
-        N CNT,RESULT,TEMP
-        S RESULT=""
-        I $$PATCH^XPDUTL("OR*3.0*243")=0 D  Q RESULT
-        .S RESULT=$P($G(^PXRMD(801.41,DIEN,51,1,0)),U) I RESULT="" Q
-        .I $P($G(^PXRMD(801.41,RESULT,0)),U,3)'="" S RESULT="" Q
-        S CNT=0 F  S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0  D
-        .S TEMP=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) I TEMP="" Q
-        .I $P($G(^PXRMD(801.41,TEMP,0)),U,3)'="" S TEMP="" Q
-        .S RESULT=$S(RESULT="":TEMP,1:RESULT_"~"_TEMP)
-        Q RESULT
-        ;
-TERM(TERMIEN,DFN,IEN)   ;
-        ;this section is use to for the term evaluation
-        N ARRAY,CNT,NODE,RESULT,TERMARR
-        N DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN
-        S (TERMARR,TFIEVAL,DATEORDR,FIEVAL)=""
-        ;build term array
-        D TERM^PXRMLDR(TERMIEN,.TERMARR)
-        ;term evaulation
-        D IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL)
-        S RESULT=$G(FIEVAL(1))
-        ;if the item is one of the WH review reminders build finding item and
-        ;text from the  the WVALERTS API in PXRMCWH
-        I RESULT=1,$P($G(^PXRMD(801.41,IEN,0)),U,16)["WHR" D
-        .N IDENT
-        .S IDENT=$P($G(^PXRMD(801.41,IEN,0)),U,16)
-        .I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D
-        ..S WVIEN=$G(FIEVAL(1,"WVIEN"))
-        ..;DBIA #4102
-        ..D RESULTS^WVALERTS(.ARRAY,WVIEN) D
-        ...K WHFIND,WHNAME
-        ...S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q
-        ...S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3)
-        ...S (ESUB,SUB)=0 F  S SUB=$O(DTXT(SUB)) Q:SUB'>0  S ESUB=SUB
-        ...S ESUB=ESUB+1
-        ...I IDENT="WHRP" D
-        ....N MOD
-        ....S DATE=""
-        ....S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1
-        ....S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20)
-        ....S STR=STR_$P($G(NODE),U,8)
-        ....S DTXT(ESUB)=STR,ESUB=ESUB+1
-        ....S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9)
-        ....S DTXT(ESUB)=STR,ESUB=ESUB+1
-        ....S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10)
-        ....S DTXT(ESUB)=STR
-        ...I IDENT="WHRM" D
-        ....S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5)
-        ....S DTXT(ESUB)=STR,ESUB=ESUB+1
-        ....S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6)
-        ....S DTXT(ESUB)=STR,ESUB=ESUB+1
-        ....S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7)
-        ....I $G(MOD)="" S STR=STR_"<none>"
-        ....E  S STR=STR_$P($G(MOD),"~",1)
-        ....S DTXT(ESUB)=STR,ESUB=ESUB+1
-        ....I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23)
-        Q +RESULT
-        ;
+PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+CODE(DFIEN,DFTYP,ARRAY) ;
+ N ARY,CNT,CNT1
+ I DFTYP["ICD9" S CODE=$P($G(^ICD9(DFIEN,0)),U) D PERIOD^ICDAPIU(CODE,.ARY)
+ I DFTYP["ICPT" S CODE=$P($$CPT^ICPTCOD(DFIEN),U,2) D PERIOD^ICPTAPIU(CODE,.ARY)
+ I $D(ARY)'>0 Q
+ I $P($G(ARY(0)),U,2)'>0 Q
+ S (CNT,CNT1)=0
+ F  S CNT=$O(ARY(CNT)) Q:CNT=""  D
+ . S ARRAY(CNT1)=CODE_":"_CNT_":"_$P($G(ARY(CNT)),U)
+ . S CNT1=CNT1+1
+ Q
+ ;
+CODES(FILE,TXIEN,ARRAY) ;Return selectable codes from taxonomy file
+ N CNT,CODE,CSCNT,DATA,DATES,DISPLAY,IEN,INSTALL,TEMP,TEXT,NODE,SUB
+ S SUB=0,CNT=0,NODE=$S(FILE=80:"SDX",FILE=81:"SPR")
+ F  S SUB=$O(^PXD(811.2,TXIEN,NODE,SUB)) Q:'SUB  D
+ .S DATA=$G(^PXD(811.2,TXIEN,NODE,SUB,0)) Q:DATA=""
+ .;Ignore if disabled
+ .S DISPLAY=""
+ .I $P(DATA,U,3)=1 Q
+ .;Get ien of code
+ .S IEN=$P(DATA,U) Q:IEN=""
+ .;get date ranges and text from period api
+ .K ARY
+ .I FILE=80 S CODE=$P($G(^ICD9(IEN,0)),U)
+ .I FILE=81 S CODE=$P($$CPT^ICPTCOD(IEN),U,2)
+ .S DISPLAY=$P($G(DATA),U,2)
+ .S TEMP=$$CODE^PXRMVAL(CODE,FILE) Q:'$P(TEMP,U)  Q:$P(TEMP,U,9)=1
+ .;Set display text from taxonomy selectable code text
+ .S TEXT=$P(DATA,U,2)
+ .;otherwise use icd9/cpt description
+ .I TEXT="",FILE=80 S TEXT=$P($$ICDDX^ICDCODE(IEN),U,3)
+ .I TEXT="",FILE=81 S TEXT=$P($$CPT^ICPTCOD(IEN),U,3)
+ .I FILE=80 D PERIOD^ICDAPIU(CODE,.ARY)
+ .I FILE=81 D PERIOD^ICPTAPIU(CODE,.ARY)
+ .I $D(ARY)'>0 Q
+ .I $P($G(ARY(0)),U,2)'>0 Q
+ .S CSCNT=0 F  S CSCNT=$O(ARY(CSCNT)) Q:CSCNT=""  D
+ ..S DATES=":"_CSCNT_":"_$P($G(ARY(CSCNT)),U)
+ ..S TEXT=$P($G(ARY(CSCNT)),U,2) I $G(DISPLAY)'="" S TEXT=DISPLAY
+ ..S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_$G(DATES)_U_$G(TEXT)
+ Q
+ ;
+EXP(TIEN,DCUR,DTTYP) ;Expand taxonomy codes
+ N CODES,CNT,FILE,LIT,CAT
+ S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE
+ S LIT="Selectable "_$S(FILE=80:"Diagnoses:",1:"Procedures:")
+ S CAT=$P($G(^PXD(811.2,TIEN,0)),U)
+ ;
+ S OCNT=OCNT+1
+ S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_U_U_U_U_CAT_U_LIT
+ ;Get selectable codes
+ D CODES(FILE,TIEN,.CODES)
+ S CNT=0
+ ;Save selectable codes as type 5 records
+ F  S CNT=$O(CODES(CNT)) Q:'CNT  D
+ .S OCNT=OCNT+1,ORY(OCNT)=5_U_DITEM_U_U_DTTYP_U_U_CODES(CNT)
+ Q
+ ;
+ ;Pass MST code as a forced value
+MST(DFTYP,DFIEN) ;
+ ;Validate finding ien
+ Q:DFIEN=""
+ ;For each MST term check if finding is mapped
+ N FOUND,TCOND,TIEN,TNAM,TSUB
+ S FOUND=0
+ F TNAM="POSITIVE","NEGATIVE","DECLINES" D  Q:FOUND
+ .;Get term IEN
+ .S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN
+ .;Check if finding is mapped to term
+ .Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN))
+ .;If exam and term condition logic is null ignore
+ .I DFTYP="AUTTEXAM(" D  Q:TCOND=""
+ ..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB
+ ..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U)
+ .;If it is then create additional prompt for MST
+ .N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ
+ .;Add to end of array
+ .S DSEQ=$O(ARRAY(""),-1)+1
+ .;Null fields
+ .S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ=""
+ .;MST status (exept for exams)
+ .I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT")
+ .;GUI process and forced value
+ .S DGUI="MST",DTYP="F"
+ .;Save in array
+ .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
+ .;Quit after the first term is found
+ .S FOUND=1
+ Q
+ ;
+REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ;
+ ;this section is use to compare the term evalution result against
+ ;the value store in the Reminder Term Status field.
+ ;If the value match and the replacement item is active then the orginal
+ ;item will be replace with the new item.
+ N TERMOUT
+ S TERMSTAT=1 I +$P(TERMNODE,U),$P($G(TERMNODE),U,2)'="" D  Q:+TERMSTAT=0
+ .N DITEMO
+ .S TERMOUT=$$TERM($P(TERMNODE,U),DFN,$G(DITEM))
+ .I TERMOUT'=$P(TERMNODE,U,2) Q
+ .I +$P(TERMNODE,U,3)'>0 S TERMSTAT=0 Q
+ .S DITEMO=DITEM,DITEM=$P(TERMNODE,U,3),DATA=$G(^PXRMD(801.41,DITEM,0))
+ .I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q
+ Q
+ ;
+TERM(TERMIEN,DFN,IEN) ;
+ ;this section is use to for the term evaluation
+ N ARRAY,CNT,NODE,RESULT,TERMARR
+ N DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN
+ S (TERMARR,TFIEVAL,DATEORDR,FIEVAL)=""
+ ;build term array
+ D TERM^PXRMLDR(TERMIEN,.TERMARR)
+ ;term evaulation
+ D IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL)
+ S RESULT=$G(FIEVAL(1))
+ ;if the item is one of the WH review reminders build finding item and
+ ;text from the  the WVALERTS API in PXRMCWH
+ I RESULT=1,$P($G(^PXRMD(801.41,IEN,0)),U,16)["WHR" D
+ .N IDENT
+ .S IDENT=$P($G(^PXRMD(801.41,IEN,0)),U,16)
+ .I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D
+ ..S WVIEN=$G(FIEVAL(1,"WVIEN"))
+ ..;DBIA #4102
+ ..D RESULTS^WVALERTS(.ARRAY,WVIEN) D
+ ...K WHFIND,WHNAME
+ ...S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q
+ ...S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3)
+ ...S (ESUB,SUB)=0 F  S SUB=$O(DTXT(SUB)) Q:SUB'>0  S ESUB=SUB
+ ...S ESUB=ESUB+1
+ ...I IDENT="WHRP" D
+ ....N MOD
+ ....S DATE=""
+ ....S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1
+ ....S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20)
+ ....S STR=STR_$P($G(NODE),U,8)
+ ....S DTXT(ESUB)=STR,ESUB=ESUB+1
+ ....S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9)
+ ....S DTXT(ESUB)=STR,ESUB=ESUB+1
+ ....S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10)
+ ....S DTXT(ESUB)=STR
+ ...I IDENT="WHRM" D
+ ....S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5)
+ ....S DTXT(ESUB)=STR,ESUB=ESUB+1
+ ....S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6)
+ ....S DTXT(ESUB)=STR,ESUB=ESUB+1
+ ....S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7)
+ ....I $G(MOD)="" S STR=STR_"<none>"
+ ....E  S STR=STR_$P($G(MOD),"~",1)
+ ....S DTXT(ESUB)=STR,ESUB=ESUB+1
+ ....I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23)
+ Q +RESULT
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m

@@ -1 @@
-PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;Build score related P/N text from score and result group
-        ; 
-        ;If not found
-START(ORY,RESULT,ORES)  ;
-        I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
-        ;
-        N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT,X
-        ;
-        I RESULT["~" S RESULT=$P(RESULT,"~")
-        S ERROR=0
-        ;
-        ;Get score using API
-        K ^TMP($J,"YSCOR")
-        I ORES("CODE")'="DOM80" D  Q:ERROR
-        .M YT=ORES
-        .F X=1:1:$L(YT("R1")) I $E(YT("R1"),X)'="X" S YT(X)=X_U_$E(YT("R1"),X)
-        .K YT("R1")
-        .D CHECKCR^YTQPXRM4(.ARRAY,.YT)
-        .S OK=0
-        .;D PREVIEW^YTAPI4(.ARRAY,.YT)
-        .I ^TMP($J,"YSCOR",1)'="[DATA]" S ORY(1)="-1^"_^TMP($J,"YSCOR",1)_^TMP($J,"YSCOD",2),ERROR=1 Q 
-        .;I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
-        .I $P($G(^TMP($J,"YSCOR",2)),"=",2)'="" S SCORE=$P($G(^TMP($J,"YSCOR",2)),"=",2),OK=1
-        .;S SUB=0,OK=0
-        .;F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  Q:OK
-        .;.I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
-        .I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
-        ;
-        ;Except for DOM80
-        I ORES("CODE")="DOM80" D
-        .I $E(ORES("R1"))="Y" S SCORE=1 Q
-        .I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q
-        .S SCORE=0
-        ;
-        S DFN=$G(ORES("DFN"))
-        S INSERT("SCORE")=SCORE
-        ;
-        ;For AIMS special formatting is required 
-        I ORES("CODE")="AIMS" D
-        .N CNT,LITS,RESP,SUM
-        .S LITS(0)="none",LITS(1)="minimal",LITS(2)="mild",LITS(3)="moderate"
-        .S LITS(4)="severe",SUM(2)=0,SUM(3)=0,SUM(4)=0
-        .F CNT=1:1 S RESP=$E(ORES("R1"),CNT) Q:RESP=""  D
-        ..S INSERT("R"_CNT)=$G(LITS(RESP))
-        ..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1
-        .F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT)
-        ;
-TEXT    ;
-        I RESULT["~" S RESULT=$P(RESULT,"~")
-        ;Load dialog results into ORY array
-        N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
-        ;Get the result elements
-        S DSEQ=0,OCNT=0
-        F  S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ  D
-        .S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB
-        .S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM
-        .;Get the result element
-        .S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T"
-        .;Get the result element condition
-        .S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13)
-        .;Skip if condition not satisfied
-        .I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN)
-        .;Get progress note text if defined
-        .N LAST,NULL,SUB,TEXT S SUB=0,LAST=0
-        .F  S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB  D
-        ..;Insert score into text (if neccessary)
-        ..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0))
-        ..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
-        ..;Add line breaks if is or preceded by blank line or starts with space
-        ..I ('NULL),LAST S TEXT="<br>"_TEXT
-        ..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
-        ..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
-        ..;Check for inserts - note there may be embedded TIU markers too
-        ..N INS
-        ..S INS=""
-        ..F  S INS=$O(INSERT(INS)) Q:INS=""  D
-        ...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q
-        ...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99)
-        ..S OCNT=OCNT+1,ORY(OCNT)=7_U_TEXT
-        Q
-        ;
-MHDLL(ORES,RESULT,SCORE,DFN)    ;
-        S INSERT("SCORE")=SCORE
-        D TEXT
-        Q
-OUT(DATA)       ;Display element details
-        N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM
-        W $P($G(^PXRMD(801.41,DITEM,0)),U)
-        W !,$J("Element Condition:  ",19)
-        W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ")
-        W !,$J("Element text:",17)
-        ;Get progress note text if defined
-        N SUB,TEXT S SUB=0
-        F  S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB  D
-        .S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT
-        Q
-        ;
-TRUE(V,COND,DFN)        ; Check if value meets element condition
-        N RESULT,SEX
-        I COND["SEX" D  Q RESULT
-        . S RESULT=0
-        . S SEX=$P($G(^DPT(DFN,0)),U,2)
-        . X COND I  S RESULT=1
-        X COND I  Q 1
-        Q 0
+PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;06/09/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;Build score related P/N text from score and result group
+ ; 
+ ;If not found
+ I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
+ ;
+ N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT
+ ;
+ S ERROR=0
+ ;
+ ;Get score using API
+ S DFN=$G(ORES("DFN"))
+ I ORES("CODE")'="DOM80" D  Q:ERROR
+ .M YT=ORES
+ .D PREVIEW^YTAPI4(.ARRAY,.YT)
+ .I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
+ .S SUB=0,OK=0
+ .F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  Q:OK
+ ..I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
+ .I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
+ ;
+ ;Except for DOM80
+ I ORES("CODE")="DOM80" D
+ .I $E(ORES("R1"))="Y" S SCORE=1 Q
+ .I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q
+ .S SCORE=0
+ ;
+ S INSERT("SCORE")=SCORE
+ ;
+ ;For AIMS special formatting is required 
+ I ORES("CODE")="AIMS" D
+ .N CNT,LITS,RESP,SUM
+ .S LITS(0)="none",LITS(1)="minimal",LITS(2)="mild",LITS(3)="moderate"
+ .S LITS(4)="severe",SUM(2)=0,SUM(3)=0,SUM(4)=0
+ .F CNT=1:1 S RESP=$E(ORES("R1"),CNT) Q:RESP=""  D
+ ..S INSERT("R"_CNT)=$G(LITS(RESP))
+ ..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1
+ .F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT)
+ ;
+ ;Load dialog results into ORY array
+ N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
+ ;Get the result elements
+ S DSEQ=0,OCNT=0
+ F  S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ  D
+ .S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB
+ .S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM
+ .;Get the result element
+ .S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T"
+ .;Get the result element condition
+ .S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13)
+ .;Skip if condition not satisfied
+ .I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN)
+ .;Get progress note text if defined
+ .N LAST,NULL,SUB,TEXT S SUB=0,LAST=0
+ .F  S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB  D
+ ..;Insert score into text (if neccessary)
+ ..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0))
+ ..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1
+ ..;Add line breaks if is or preceded by blank line or starts with space
+ ..I ('NULL),LAST S TEXT="<br>"_TEXT
+ ..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
+ ..S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
+ ..;Check for inserts - note there may be embedded TIU markers too
+ ..N INS
+ ..S INS=""
+ ..F  S INS=$O(INSERT(INS)) Q:INS=""  D
+ ...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q
+ ...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99)
+ ..S OCNT=OCNT+1,ORY(OCNT)=7_U_TEXT
+ Q
+ ;
+OUT(DATA) ;Display element details
+ N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM
+ W $P($G(^PXRMD(801.41,DITEM,0)),U)
+ W !,$J("Element Condition:  ",19)
+ W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ")
+ W !,$J("Element text:",17)
+ ;Get progress note text if defined
+ N SUB,TEXT S SUB=0
+ F  S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB  D
+ .S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT
+ Q
+ ;
+TRUE(V,COND,DFN) ; Check if value meets element condition
+ N RESULT,SEX
+ I COND["SEX" D  Q RESULT
+ . S RESULT=0
+ . S SEX=$P($G(^DPT(DFN,0)),U,2)
+ . X COND I  S RESULT=1
+ X COND I  Q 1
+ Q 0

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m

@@ -1 @@
-PXRMDLR1        ; SLC/AGP - DIALOG ORPHAN REPORT. ; 11/16/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=======================================================================
-START(NUM)      ;
-        N DIR,POP,ZTDESC,ZTRTN,ZTSAVE
-        S %ZIS="M"
-        I NUM=1 S ZTDESC="Dialog Orphan Report" S ZTRTN="EN^PXRMDLR1"
-        I NUM=2 S ZTDESC="Empty Reminder Dialogs Report" S ZTRTN="EN1^PXRMDLR1"
-        S ZTSAVE("*")=""
-        D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS)
-        Q
-        ;
-EN      ;
-        N NAME,IEN,TYPE
-        K ^TMP("PXRMDLR1",$J)
-        S IEN=0
-        S NAME="" F  S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""  D
-        . S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
-        . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
-        . I $G(TYPE)=""!($G(TYPE)="R") Q
-        . I $D(^PXRMD(801.41,"AD",IEN)) Q
-        . S TYPE=$S(TYPE="P":"VPROMPT",TYPE="E":"ELEMENT",TYPE="F":"VVALUE",TYPE="G":"GROUP",TYPE="S":"RGROUP",TYPE="T":"RELEMENT")
-        . S ^TMP("PXRMDLR1",$J,TYPE,NAME)=IEN
-        I $D(^TMP("PXRMDLR1",$J))>0 D OUTPUT
-        Q
-        ;
-EN1     ;
-        N DONE,FOUND,NAME,IEN,TITLE,TYPE
-        W @IOF
-        S PCNT=0,PAGE=1,DONE=0,FOUND=0
-        S TITLE="Empty Reminder Dialogs Report"
-        D HEADER(.PCNT,PAGE,TITLE)
-        S IEN=0
-        S NAME="" F  S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""!(DONE=1)  D
-        . S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
-        . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
-        . I ($G(TYPE)'="R") Q
-        . I $D(^PXRMD(801.41,IEN,10))'=0 Q
-        . S FOUND=1
-        . I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
-        . W !,"  "_$G(NAME) S PCNT=PCNT+1 I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
-        I FOUND=0 W !,"No empty dialog found"
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
-        . W !
-        . S DIR(0)="E" D ^DIR K DIR
-        Q
-        ;
-OUTPUT  ;
-        N CAT,DONE,LENGTH,NAME,OCAT,PAGE,PCNT,TITLE,TYPE,X
-        W @IOF
-        S PCNT=0,PAGE=1,DONE=0
-        S TITLE="Reminder Dialog Elements Orphan Report"
-        D HEADER(.PCNT,PAGE,TITLE)
-        W !
-        F CAT="ELEMENT","GROUP","RELEMENT","RGROUP","VPROMPT","VVALUE" D
-        . I DONE=1 Q
-        . I $D(^TMP("PXRMDLR1",$J,CAT))'>0 Q
-        . S TYPE=$S(CAT="VPROMPT":"Additional Prompts",CAT="ELEMENT":"Dialog Elements",CAT="VVALUE":"Force Values",CAT="GROUP":"Dialog Groups",CAT="RGROUP":"Result Groups",CAT="RELEMENT":"Result Elements")
-        . I (PCNT+4)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
-        . S LENGTH=$L(TYPE) W !!,TYPE,! F X=1:1:LENGTH W "="
-        . S PCNT=PCNT+4
-        . I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
-        . S NAME="" F  S NAME=$O(^TMP("PXRMDLR1",$J,CAT,NAME)) Q:NAME=""!(DONE=1)  D
-        . .W !,$$LJ^XLFSTR("",4)_NAME S PCNT=PCNT+1
-        . .I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
-        K ^TMP("PXRMDLR1",$J)
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
-        . W !
-        . S DIR(0)="E" D ^DIR K DIR
-        Q
-        ;
-HEADER(PCNT,PAGE,TITLE) ;
-        W $$LJ^XLFSTR(TITLE,70)_"Page: "_PAGE,!
-        F X=1:1:80 W "="
-        S PCNT=PCNT+3
-        Q
-        ;
-PAGE(PCNT,PAGE) ;
-        N DUOUT,DTOUT,DIROUT,DIR
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
-        .S DIR(0)="E"
-        .W !
-        .D ^DIR K DIR
-        I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
-        W:$D(IOF) @IOF
-        S PAGE=PAGE+1,PCNT=0
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF D HEADER(.PCNT,PAGE,TITLE)
-        Q
+PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 02/04/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=======================================================================
+START(NUM) ;
+ N DIR,POP,ZTDESC,ZTRTN,ZTSAVE
+ S %ZIS="M"
+ I NUM=1 S ZTDESC="Dialog Orphan Report" S ZTRTN="EN^PXRMDLR1"
+ I NUM=2 S ZTDESC="Empty Reminder Dialogs Report" S ZTRTN="EN1^PXRMDLR1"
+ S ZTSAVE("*")=""
+ D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS)
+ Q
+ ;
+EN ;
+ N NAME,IEN,TYPE
+ K ^TMP("PXRMDLR1",$J)
+ S IEN=0
+ S NAME="" F  S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""  D
+ . S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
+ . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
+ . I $G(TYPE)=""!($G(TYPE)="R") Q
+ . I $D(^PXRMD(801.41,"AD",IEN)) Q
+ . S TYPE=$S(TYPE="P":"VPROMPT",TYPE="E":"ELEMENT",TYPE="F":"VVALUE",TYPE="G":"GROUP",TYPE="S":"RGROUP",TYPE="T":"RELEMENT")
+ . S ^TMP("PXRMDLR1",$J,TYPE,NAME)=IEN
+ I $D(^TMP("PXRMDLR1",$J))>0 D OUTPUT
+ Q
+ ;
+EN1 ;
+ N DONE,FOUND,NAME,IEN,TITLE,TYPE
+ W @IOF
+ S PCNT=0,PAGE=1,DONE=0,FOUND=0
+ S TITLE="Empty Reminder Dialogs Report"
+ D HEADER(.PCNT,PAGE,TITLE)
+ S IEN=0
+ S NAME="" F  S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""!(DONE=1)  D
+ . S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0
+ . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
+ . I ($G(TYPE)'="R") Q
+ . I $D(^PXRMD(801.41,IEN,10))'=0 Q
+ . S FOUND=1
+ . I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
+ . W !,"  "_$G(NAME) S PCNT=PCNT+1 I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
+ I FOUND=0 W !,"No empty dialog found"
+ I ($E(IOST)="C")&(IO=IO(0)) D
+ . W !
+ . S DIR(0)="E" D ^DIR K DIR
+ Q
+ ;
+OUTPUT ;
+ N CAT,DONE,LENGTH,NAME,OCAT,PAGE,PCNT,TITLE,TYPE,X
+ W @IOF
+ S PCNT=0,PAGE=1,DONE=0
+ S TITLE="Reminder Dialog Elements Orphan Report"
+ D HEADER(.PCNT,PAGE,TITLE)
+ W !
+ F CAT="ELEMENT","GROUP","RELEMENT","RGROUP","VPROMPT","VVALUE" D
+ . I DONE=1 Q
+ . I $D(^TMP("PXRMDLR1",$J,CAT))'>0 Q
+ . S TYPE=$S(CAT="VPROMPT":"Additional Prompts",CAT="ELEMENT":"Dialog Elements",CAT="VVALUE":"Force Values",CAT="GROUP":"Dialog Groups",CAT="RGROUP":"Result Groups",CAT="RELEMENT":"Result Elements")
+ . I (PCNT+4)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
+ . S LENGTH=$L(TYPE) W !!,TYPE,! F X=1:1:LENGTH W "="
+ . S PCNT=PCNT+4
+ . I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
+ . S NAME="" F  S NAME=$O(^TMP("PXRMDLR1",$J,CAT,NAME)) Q:NAME=""!(DONE=1)  D
+ . .W !,$$LJ^XLFSTR("",4)_NAME S PCNT=PCNT+1
+ . .I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
+ K ^TMP("PXRMDLR1",$J)
+ I ($E(IOST)="C")&(IO=IO(0)) D
+ . W !
+ . S DIR(0)="E" D ^DIR K DIR
+ Q
+ ;
+HEADER(PCNT,PAGE,TITLE) ;
+ W $$LJ^XLFSTR(TITLE,70)_"Page: "_PAGE,!
+ F X=1:1:80 W "="
+ S PCNT=PCNT+3
+ Q
+ ;
+PAGE(PCNT,PAGE) ;
+ N DUOUT,DTOUT,DIROUT,DIR
+ I ($E(IOST)="C")&(IO=IO(0)) D
+ .S DIR(0)="E"
+ .W !
+ .D ^DIR K DIR
+ I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
+ W:$D(IOF) @IOF
+ S PAGE=PAGE+1,PCNT=0
+ I $E(IOST)="C",IO=IO(0) W @IOF D HEADER(.PCNT,PAGE,TITLE)
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m

@@ -1 @@
-PXRMDNVA        ; SLC/PKR - Handle non-VA med findings. ;03/14/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;===============================================
-GETDATA(DAS,FIEVT)      ;Return data for an non-VA med finding.
-        ;DBIA #3793
-        D NVA^PSOPXRM1(DAS,.FIEVT)
-        S FIEVT("VALUE")=FIEVT("STATUS")
-        I $G(FIEVT("START DATE"))="" S FIEVT("START DATE")=FIEVT("DOCUMENTED DATE")
-        S FIEVT("DURATION")=$$DURATION^PXRMDATE(FIEVT("START DATE"),FIEVT("DISCONTINUED DATE"))
-        Q
-        ;
-        ;===============================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;Evaluate terms.
-        D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
-        Q
-        ;
-        ;====================================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        N DATE,JND,NOUT,TEMP,TEXTOUT
-        S TEMP="Non-VA med: "_IFIEVAL("ORDERABLE ITEM")_" = "
-        S TEMP=TEMP_"("_$$EDATE^PXRMDATE(IFIEVAL("START DATE"))
-        S DATE=IFIEVAL("DISCONTINUED DATE")
-        S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
-        D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        Q
-        ;
-        ;===============================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        N DATE,JND,NOUT,TEMP,TEXTOUT
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Non-VA med: "_IFIEVAL("ORDERABLE ITEM")
-        S DATE=IFIEVAL("START DATE")
-        S TEMP="Start Date: "_$$EDATE^PXRMDATE(DATE)
-        S DATE=IFIEVAL("DISCONTINUED DATE")
-        S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
-        S TEMP=TEMP_" Discontinued Date: "_DATE
-        I $D(IFIEVAL("DURATION")) S TEMP=TEMP_"  Duration: "_IFIEVAL("DURATION")_" D"
-        S TEMP=TEMP_" Status: "_IFIEVAL("STATUS")_"\\"
-        S TEMP=TEMP_"Dosage Form: "_IFIEVAL("DOSAGE FORM")
-        S TEMP=TEMP_" Dosage: "_IFIEVAL("DOSAGE")
-        S TEMP=TEMP_" Medication Route: "_IFIEVAL("MEDICATION ROUTE")
-        D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
+PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;05/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;===============================================
+GETDATA(DAS,FIEVT) ;Return data for an non-VA med finding.
+ ;DBIA #3793
+ D NVA^PSOPXRM1(DAS,.FIEVT)
+ S FIEVT("VALUE")=FIEVT("STATUS")
+ I $G(FIEVT("START DATE"))="" S FIEVT("START DATE")=FIEVT("DOCUMENTED DATE")
+ S FIEVT("DURATION")=$$DURATION^PXRMDATE(FIEVT("START DATE"),FIEVT("DISCONTINUED DATE"))
+ Q
+ ;
+ ;===============================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate terms.
+ D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
+ Q
+ ;
+ ;====================================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N JND,NOUT,TEMP,TEXTOUT
+ S TEMP="Non-VA med: "_IFIEVAL("ORDERABLE ITEM")_" = "
+ S TEMP=TEMP_"("_$$EDATE^PXRMDATE(IFIEVAL("START DATE"))
+ S TEMP=TEMP_" - "_$$EDATE^PXRMDATE(IFIEVAL("STOP DATE"))_")"
+ D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ Q
+ ;
+ ;===============================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ N DATE,JND,NOUT,TEMP,TEXTOUT
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Non-VA med: "_IFIEVAL("ORDERABLE ITEM")
+ S DATE=IFIEVAL("START DATE")
+ S TEMP="Start Date: "_$$EDATE^PXRMDATE(DATE)
+ S DATE=IFIEVAL("DISCONTINUED DATE")
+ S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
+ S TEMP=TEMP_" Discontinued Date: "_DATE
+ I $D(IFIEVAL("DURATION")) S TEMP=TEMP_"  Duration: "_IFIEVAL("DURATION")_" D"
+ S TEMP=TEMP_" Status: "_IFIEVAL("STATUS")_"\\"
+ S TEMP=TEMP_"Dosage Form: "_IFIEVAL("DOSAGE FORM")
+ S TEMP=TEMP_" Dosage: "_IFIEVAL("DOSAGE")
+ S TEMP=TEMP_" Medication Route: "_IFIEVAL("MEDICATION ROUTE")
+ D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m

@@ -1 @@
-PXRMDRGR        ; SLC/PKR - Handle groups of drug findings. ;06/20/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;Groups are drug classes or VA Generic.
-        ;==================================================
-EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL)    ;Evaluate drug group findings.
-        N DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX
-        S NOINDEX=0
-        I $G(^PXRMINDX(52,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("D",PXRMITEM,52)
-        . S NOINDEX=1
-        I $G(^PXRMINDX(55,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("D",PXRMITEM,55)
-        . S NOINDEX=1
-        S DRGRIEN=""
-        F  S DRGRIEN=$O(DEFARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0  D
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,DRGRIEN,FINDING)) Q:+FINDING=0  D
-        .. I NOINDEX S FIEVAL(FINDING)=0 Q
-        .. K FIEVT,FINDPA
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. D FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT)
-        .. M FIEVAL(FINDING)=FIEVT
-        .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
-        Q
-        ;
-        ;==================================================
-EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group
-        ;terms for building patient lists.
-        N DRGRIEN,NOINDEX,PFINDPA
-        N TEMP,TFINDPA,TFINDING
-        S NOINDEX=0
-        I $G(^PXRMINDX(52,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
-        . S NOINDEX=1
-        I $G(^PXRMINDX(55,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
-        . S NOINDEX=1
-        I NOINDEX Q
-        S DRGRIEN=""
-        F  S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0  D
-        .. K PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D GPLIST(DRGRIEN,.PFINDPA,XREF,.PLIST)
-        Q
-        ;
-        ;==================================================
-EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug
-        ;group terms.
-        N DRGRIEN,FIEVT,NOINDEX,PFINDPA
-        N TEMP,TFINDPA,TFINDING
-        S NOINDEX=0
-        I $G(^PXRMINDX(52,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
-        . S NOINDEX=1
-        I $G(^PXRMINDX(55,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
-        . S NOINDEX=1
-        S DRGRIEN=""
-        F  S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0  D
-        .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
-        .. K FIEVT,PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT)
-        .. M TFIEVAL(TFINDING)=FIEVT
-        .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
-        Q
-        ;
-        ;==================================================
-FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL)   ;
-        N DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL
-        N NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL
-        N SDIR,TDATE,TIND
-        S NOCC=$P(FINDPA(0),U,14)
-        I NOCC="" S NOCC=1
-        S SDIR=$S(NOCC<0:+1,1:-1)
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        ;Determine where we search.
-        D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
-        D GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND)
-        I DREND=0,POIEND=0 S FIEVAL=0 Q
-        S (DRUGIEN,NFOUND)=0
-        F  S DRUGIEN=+$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0  D
-        . I DRUGIEN'<DRBEG,DRUGIEN'>DREND S DRUG=DRUGIEN
-        . E  S DRUG=0
-        .;DBIA #221
-        . S POIIEN=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
-        . I POIIEN'<POIBEG,POIIEN'>POIEND S POI=POIIEN
-        . E  S POI=0
-        . K FIEVT
-        . D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT)
-        . I FIEVT D
-        .. S IND=0
-        .. F  S IND=+$O(FIEVT(IND)) Q:IND=0  D
-        ...;Make sure this is not already on the list
-        ... I $$ONLIST(.FIEVTL,IND,.FIEVT) Q
-        ... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
-        ... M FIEVTL(NFOUND)=FIEVT(IND)
-        ... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
-        ...;Don't keep more than NOCC occurrences on the list.
-        ... I NFOUND>NOCC D
-        .... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,""))
-        .... K FIEVTL(TIND),DATEORDR(TDATE,TIND)
-        I NFOUND=0 S FIEVAL=0 Q
-        ;Order by date.
-        S DATE="",NFOUND=0
-        F  S DATE=$O(DATEORDR(DATE),SDIR)  Q:(DATE="")!(NFOUND=NOCC)  D
-        . S IND=0
-        . F  S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC)  D
-        .. S NFOUND=NFOUND+1
-        .. M FIEVAL(NFOUND)=FIEVTL(IND)
-        ;Save the finding result.
-        D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
-        Q
-        ;
-        ;==================================================
-GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND)     ;Return the beginning drug and 
-        ;ending drug for a patient.
-        N IBEG,IEND,OBEG,OEND
-        I $D(RXTYL("I")) D
-        . S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0))
-        . S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1)
-        E  S (IBEG,IEND)=0
-        I $D(RXTYL("O")) D
-        . S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0))
-        . S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1)
-        E  S (OBEG,OEND)=0
-        S DRBEG=$S(IBEG<OBEG:IBEG,1:OBEG)
-        S DREND=$S(IEND>OEND:IEND,1:OEND)
-        I $D(RXTYL("N")) D
-        . S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0))
-        . S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1)
-        E  S (POIBEG,POIEND)=0
-        Q
-        ;
-        ;==================================================
-GPLIST(DRGRIEN,PFINDPA,XREF,PLIST)      ;
-        N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL
-        N TF,TEMP,TGLIST,TLIST
-        S TGLIST="GPLIST_PXRMDRGR"
-        K ^TMP($J,TGLIST)
-        ;Determine where we search.
-        D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
-        S DRUGIEN=0
-        F  S DRUGIEN=$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:+DRUGIEN=0  D
-        . ;DBIA #221
-        . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
-        . I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
-        . I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
-        . I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
-        ;Return the NOCC most recent results for each DFN.
-        S NOCC=$P(FINDPA(0),U,14)
-        S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
-        F TF=0,1 D
-        . S DFN=0
-        . F  S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN=""  D
-        .. K TLIST
-        .. S ITEM=""
-        .. F  S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM=""  D
-        ... S NFOUND=""
-        ... F  S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND=""  D
-        .... S FILENUM=""
-        .... F  S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM=""  D
-        ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
-        ..... S DATE=+$P(TEMP,U,3)
-        ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
-        .. S DATE="",NFOUND=0
-        .. F  S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC)  D
-        ... S ITEM=""
-        ... F  S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC)  D
-        .... S IND=""
-        .... F  S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC)  D
-        ..... S FILENUM=""
-        ..... F  S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC)  D
-        ...... S NFOUND=NFOUND+1
-        ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
-        K ^TMP($J,TGLIST)
-        Q
-        ;
-        ;==================================================
-ONLIST(FIEVTL,IND,FIEVT)        ;Return true if FIEVT(IND) is already on
-        ;FIEVTL.
-        N JND,ONLIST
-        S (JND,ONLIST)=0
-        F  S JND=$O(FIEVTL(JND)) Q:(ONLIST)!(JND="")  D
-        . I FIEVTL(JND,"FILE NUMBER")'=FIEVT(IND,"FILE NUMBER") Q
-        . I FIEVTL(JND,"DAS")'=FIEVT(IND,"DAS") Q
-        . S ONLIST=1
-        Q ONLIST
-        ;
+PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/12/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;Groups are drug classes or VA Generic.
+ ;==================================================
+EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings.
+ N DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX
+ S NOINDEX=0
+ I $G(^PXRMINDX(52,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("D",PXRMITEM,52)
+ . S NOINDEX=1
+ I $G(^PXRMINDX(55,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("D",PXRMITEM,55)
+ . S NOINDEX=1
+ S DRGRIEN=""
+ F  S DRGRIEN=$O(DEFARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0  D
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,DRGRIEN,FINDING)) Q:+FINDING=0  D
+ .. I NOINDEX S FIEVAL(FINDING)=0 Q
+ .. K FIEVT,FINDPA
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. D FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT)
+ .. M FIEVAL(FINDING)=FIEVT
+ .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
+ Q
+ ;
+ ;==================================================
+EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group
+ ;terms for building patient lists.
+ N DRGRIEN,NOINDEX,PFINDPA
+ N TEMP,TFINDPA,TFINDING
+ S NOINDEX=0
+ I $G(^PXRMINDX(52,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
+ . S NOINDEX=1
+ I $G(^PXRMINDX(55,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
+ . S NOINDEX=1
+ I NOINDEX Q
+ S DRGRIEN=""
+ F  S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0  D
+ .. K PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D GPLIST(DRGRIEN,.PFINDPA,XREF,.PLIST)
+ Q
+ ;
+ ;==================================================
+EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug
+ ;group terms.
+ N DRGRIEN,FIEVT,NOINDEX,PFINDPA
+ N TEMP,TFINDPA,TFINDING
+ S NOINDEX=0
+ I $G(^PXRMINDX(52,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
+ . S NOINDEX=1
+ I $G(^PXRMINDX(55,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
+ . S NOINDEX=1
+ S DRGRIEN=""
+ F  S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0  D
+ .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
+ .. K FIEVT,PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT)
+ .. M TFIEVAL(TFINDING)=FIEVT
+ .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
+ Q
+ ;
+ ;==================================================
+FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ;
+ N DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL
+ N NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL
+ N SDIR,TDATE,TIND
+ S NOCC=$P(FINDPA(0),U,14)
+ I NOCC="" S NOCC=1
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ ;Determine where we search.
+ D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
+ D GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND)
+ I DREND=0,POIEND=0 S FIEVAL=0 Q
+ S (DRUGIEN,NFOUND)=0
+ F  S DRUGIEN=+$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0  D
+ . I DRUGIEN'<DRBEG,DRUGIEN'>DREND S DRUG=DRUGIEN
+ . E  S DRUG=0
+ .;DBIA #221
+ . S POIIEN=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
+ . I POIIEN'<POIBEG,POIIEN'>POIEND S POI=POIIEN
+ . E  S POI=0
+ . K FIEVT
+ . D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT)
+ . I FIEVT D
+ .. S IND=0
+ .. F  S IND=+$O(FIEVT(IND)) Q:IND=0  D
+ ... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
+ ... M FIEVTL(NFOUND)=FIEVT(IND)
+ ... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
+ ...;Don't keep more than NOCC occurrences on the list.
+ ... I NFOUND>NOCC D
+ .... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,""))
+ .... K FIEVTL(TIND),DATEORDR(TDATE,TIND)
+ I NFOUND=0 S FIEVAL=0 Q
+ ;Order by date.
+ S DATE="",NFOUND=0
+ F  S DATE=$O(DATEORDR(DATE),SDIR)  Q:(DATE="")!(NFOUND=NOCC)  D
+ . S IND=0
+ . F  S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC)  D
+ .. S NFOUND=NFOUND+1
+ .. M FIEVAL(NFOUND)=FIEVTL(IND)
+ ;Save the finding result.
+ D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
+ Q
+ ;
+ ;==================================================
+GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and 
+ ;ending drug for a patient.
+ N IBEG,IEND,OBEG,OEND
+ I $D(RXTYL("I")) D
+ . S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0))
+ . S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1)
+ E  S (IBEG,IEND)=0
+ I $D(RXTYL("O")) D
+ . S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0))
+ . S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1)
+ E  S (OBEG,OEND)=0
+ S DRBEG=$S(IBEG<OBEG:IBEG,1:OBEG)
+ S DREND=$S(IEND>OEND:IEND,1:OEND)
+ I $D(RXTYL("N")) D
+ . S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0))
+ . S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1)
+ E  S (POIBEG,POIEND)=0
+ Q
+ ;
+ ;==================================================
+GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ;
+ N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL
+ N TF,TEMP,TGLIST,TLIST
+ S TGLIST="GPLIST_PXRMDRGR"
+ K ^TMP($J,TGLIST)
+ ;Determine where we search.
+ D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
+ S DRUGIEN=0
+ F  S DRUGIEN=$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:+DRUGIEN=0  D
+ . ;DBIA #221
+ . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
+ . I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
+ . I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
+ . I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
+ ;Return the NOCC most recent results for each DFN.
+ S NOCC=$P(FINDPA(0),U,14)
+ S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
+ F TF=0,1 D
+ . S DFN=0
+ . F  S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN=""  D
+ .. K TLIST
+ .. S ITEM=""
+ .. F  S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM=""  D
+ ... S NFOUND=""
+ ... F  S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND=""  D
+ .... S FILENUM=""
+ .... F  S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM=""  D
+ ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
+ ..... S DATE=+$P(TEMP,U,3)
+ ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
+ .. S DATE="",NFOUND=0
+ .. F  S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC)  D
+ ... S ITEM=""
+ ... F  S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC)  D
+ .... S IND=""
+ .... F  S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC)  D
+ ..... S FILENUM=""
+ ..... F  S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC)  D
+ ...... S NFOUND=NFOUND+1
+ ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
+ K ^TMP($J,TGLIST)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m

@@ -1 @@
-PXRMDRUG        ; SLC/PKR - Handle drug findings. ;04/23/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;===============================================
-DEVAL(DFN,FINDPA,DEFARR,FINDING,RXTYL,DRUG,POI,FIEVAL)  ;Evaluate a drug
-        ;finding.
-        I DRUG=0,POI=0 S FIEVAL=0 Q
-        N DTERM,FIEVT
-        ;Create the pseudo term.
-        S DTERM(0)="DTERM",DTERM("IEN")=0
-        I $D(RXTYL("I")),DRUG>0 D
-        . M DTERM(20,1)=DEFARR(20,FINDING)
-        . S $P(DTERM(20,1,0),U,1)=DRUG_";PS(55,"
-        . S DTERM("E","PS(55,",DRUG,1)=""
-        I $D(RXTYL("O")),DRUG>0 D
-        . M DTERM(20,3)=DEFARR(20,FINDING)
-        . S $P(DTERM(20,3,0),U,1)=DRUG_";PSRX("
-        . S DTERM("E","PSRX(",DRUG,3)=""
-        I $D(RXTYL("N")),POI>0 D
-        . M DTERM(20,2)=DEFARR(20,FINDING)
-        . S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
-        . S DTERM("E","PS(55NVA,",POI,2)=""
-        K FIEVT
-        D IEVALTER^PXRMTERM(DFN,.FINDPA,.DTERM,1,.FIEVT)
-        M FIEVAL=FIEVT(1)
-        I FIEVAL S FIEVAL("FINDING")=DRUG_";PSDRUG(",FIEVAL("DISPENSE DRUG")=DRUG
-        Q
-        ;
-        ;===============================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate drug findings.
-        N DRUGIEN,DTERM,FIEVT,FINDPA,FINDING
-        N NOINDEX,POI,RXTYL
-        S NOINDEX=0
-        I $G(^PXRMINDX(52,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("D",PXRMITEM,52)
-        . S NOINDEX=1
-        I $G(^PXRMINDX(55,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("D",PXRMITEM,55)
-        . S NOINDEX=1
-        S DRUGIEN=""
-        F  S DRUGIEN=$O(DEFARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0  D
-        . ;DBIA #221
-        . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,DRUGIEN,FINDING)) Q:+FINDING=0  D
-        .. I NOINDEX S FIEVAL(FINDING)=0 Q
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. K FIEVT,RXTYL
-        ..;Determine where we search.
-        .. D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
-        .. D DEVAL(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUGIEN,POI,.FIEVT)
-        .. M FIEVAL(FINDING)=FIEVT
-        Q
-        ;
-        ;===============================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;Evaluate drug terms for
-        ;building patient lists.
-        N BDT,EDT,DATE,DFN,DRUGIEN,ITEM,FILENUM,IND,LIST,NFOUND,NOCC,NOINDEX
-        N PFINDPA,POI,RXTYL,TEMP,TF,TFINDPA,TFINDING,TGLIST,TLIST
-        S NOINDEX=0
-        I $G(^PXRMINDX(52,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
-        . S NOINDEX=1
-        I $G(^PXRMINDX(55,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
-        . S NOINDEX=1
-        I NOINDEX Q
-        S TGLIST="EVALPL_PXRMDRUG"
-        K ^TMP($J,TGLIST)
-        S DRUGIEN=""
-        F  S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0  D
-        . ;DBIA #221
-        . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0  D
-        .. K PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        ..;Determine where we search.
-        .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
-        .. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
-        .. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
-        .. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
-        ;Return the NOCC most recent results for each DFN.
-        S NOCC=$P(FINDPA(0),U,14)
-        S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
-        F TF=0,1 D
-        . S DFN=0
-        . F  S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN=""  D
-        .. K TLIST
-        .. S ITEM=""
-        .. F  S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM=""  D
-        ... S NFOUND=""
-        ... F  S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND=""  D
-        .... S FILENUM=""
-        .... F  S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM=""  D
-        ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
-        ..... S DATE=+$P(TEMP,U,3)
-        ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
-        .. S DATE="",NFOUND=0
-        .. F  S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC)  D
-        ... S ITEM=""
-        ... F  S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC)  D
-        .... S IND=""
-        .... F  S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC)  D
-        ..... S FILENUM=""
-        ..... F  S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC)  D
-        ...... S NFOUND=NFOUND+1
-        ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
-        K ^TMP($J,TGLIST)
-        Q
-        ;
-        ;===============================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;Evaluate drug terms.
-        N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,JND,NOINDEX,PFINDPA,POI
-        N RXTYL,TEMP,TFINDING,TFINDPA
-        N DATEORDR,NOCC,SDIR
-        S NOINDEX=0
-        I $G(^PXRMINDX(52,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
-        . S NOINDEX=1
-        I $G(^PXRMINDX(55,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
-        . S NOINDEX=1
-        ;Set NOCC and SDIR.
-        S NOCC=$P(FINDPA(0),U,14)
-        I NOCC="" S NOCC=1
-        S SDIR=$S(NOCC<0:+1,1:-1)
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        S DRUGIEN=""
-        F  S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0  D
-        . ;DBIA #221
-        . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0  D
-        .. S TFIEVAL(TFINDING)=0
-        .. I NOINDEX Q
-        .. K DTERM,DTFIEVAL,PFINDPA,TFINDPA
-        .. S DTERM(0)="DTERM",DTERM("IEN")=0
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        ..;Determine where we search.
-        .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
-        .. I $D(RXTYL("I")) D
-        ... M DTERM(20,1)=TERMARR(20,TFINDING)
-        ... S $P(DTERM(20,1,0),U,1)=DRUGIEN_";PS(55,"
-        ... S DTERM("E","PS(55,",DRUGIEN,1)=""
-        .. I $D(RXTYL("N")),POI'="" D
-        ... M DTERM(20,2)=TERMARR(20,TFINDING)
-        ... S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
-        ... S DTERM("E","PS(55NVA,",POI,2)=""
-        .. I $D(RXTYL("O")) D
-        ... M DTERM(20,3)=TERMARR(20,TFINDING)
-        ... S $P(DTERM(20,3,0),U,1)=DRUGIEN_";PSRX("
-        ... S DTERM("E","PSRX(",DRUGIEN,3)=""
-        .. D IEVALTER^PXRMTERM(DFN,.PFINDPA,.DTERM,TFINDING,.DTFIEVAL)
-        .. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR)
-        .. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL)
-        ..;Save the dispense drug
-        .. S JND=0
-        .. F  S JND=+$O(TFIEVAL(TFINDING,JND)) Q:JND=0  S TFIEVAL(TFINDING,JND,"DISPENSE DRUG")=DRUGIEN
-        Q
-        ;
-        ;===============================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        N DRUG,DRUGIEN,IND,FTYPE,NAME,PFIEVAL,TEMP
-        S DRUGIEN=IFIEVAL("DISPENSE DRUG")
-        ;DBIA #10043
-        S DRUG=$P(^PSDRUG(DRUGIEN,0),U,1)
-        S NAME="Drug: "_DRUG_" = "
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S TEMP=IFIEVAL(IND,"FINDING")
-        . S FTYPE=$P(TEMP,";",2)
-        . K PFIEVAL M PFIEVAL=IFIEVAL(IND)
-        . S PFIEVAL("DISPENSE DRUG")=DRUG
-        . I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
-        . I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
-        . I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;===============================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        N DRUG,FTYPE,IND,PFIEVAL,TEMP,TEXTOUT
-        ;DBIA #10043
-        S DRUG=$P(^PSDRUG(IFIEVAL("DISPENSE DRUG"),0),U,1)
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S TEMP=IFIEVAL(IND,"FINDING")
-        . S FTYPE=$P(TEMP,";",2)
-        . K PFIEVAL M PFIEVAL=IFIEVAL(IND)
-        . S PFIEVAL("DISPENSE DRUG")=DRUG
-        . I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
-        . I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
-        . I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
-        Q
-        ;
+PXRMDRUG ; SLC/PKR - Handle drug findings. ;06/08/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;===============================================
+DEVAL(DFN,FINDPA,DEFARR,FINDING,RXTYL,DRUG,POI,FIEVAL) ;Evaluate a drug
+ ;finding.
+ I DRUG=0,POI=0 S FIEVAL=0 Q
+ N DTERM,FIEVT
+ ;Create the pseudo term.
+ S DTERM(0)="DTERM",DTERM("IEN")=0
+ I $D(RXTYL("I")),DRUG>0 D
+ . M DTERM(20,1)=DEFARR(20,FINDING)
+ . S $P(DTERM(20,1,0),U,1)=DRUG_";PS(55,"
+ . S DTERM("E","PS(55,",DRUG,1)=""
+ I $D(RXTYL("O")),DRUG>0 D
+ . M DTERM(20,3)=DEFARR(20,FINDING)
+ . S $P(DTERM(20,3,0),U,1)=DRUG_";PSRX("
+ . S DTERM("E","PSRX(",DRUG,3)=""
+ I $D(RXTYL("N")),POI>0 D
+ . M DTERM(20,2)=DEFARR(20,FINDING)
+ . S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
+ . S DTERM("E","PS(55NVA,",POI,2)=""
+ K FIEVT
+ D IEVALTER^PXRMTERM(DFN,.FINDPA,.DTERM,1,.FIEVT)
+ M FIEVAL=FIEVT(1)
+ I FIEVAL S FIEVAL("FINDING")=DRUG_";PSDRUG(",FIEVAL("DISPENSE DRUG")=DRUG
+ Q
+ ;
+ ;===============================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate drug findings.
+ N DRUGIEN,DTERM,FIEVT,FINDPA,FINDING
+ N NOINDEX,POI,RXTYL
+ S NOINDEX=0
+ I $G(^PXRMINDX(52,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("D",PXRMITEM,52)
+ . S NOINDEX=1
+ I $G(^PXRMINDX(55,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("D",PXRMITEM,55)
+ . S NOINDEX=1
+ S DRUGIEN=""
+ F  S DRUGIEN=$O(DEFARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0  D
+ . ;DBIA #221
+ . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,DRUGIEN,FINDING)) Q:+FINDING=0  D
+ .. I NOINDEX S FIEVAL(FINDING)=0 Q
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. K FIEVT,RXTYL
+ ..;Determine where we search.
+ .. D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
+ .. D DEVAL(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUGIEN,POI,.FIEVT)
+ .. M FIEVAL(FINDING)=FIEVT
+ Q
+ ;
+ ;===============================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate drug terms for
+ ;building patient lists.
+ N BDT,EDT,DATE,DFN,DRUGIEN,ITEM,FILENUM,IND,LIST,NFOUND,NOCC,NOINDEX
+ N PFINDPA,POI,RXTYL,TEMP,TF,TFINDPA,TFINDING,TGLIST,TLIST
+ S NOINDEX=0
+ I $G(^PXRMINDX(52,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
+ . S NOINDEX=1
+ I $G(^PXRMINDX(55,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
+ . S NOINDEX=1
+ I NOINDEX Q
+ S TGLIST="EVALPL_PXRMDRUG"
+ K ^TMP($J,TGLIST)
+ S DRUGIEN=""
+ F  S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0  D
+ . ;DBIA #221
+ . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0  D
+ .. K PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ ..;Determine where we search.
+ .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
+ .. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
+ .. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
+ .. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
+ ;Return the NOCC most recent results for each DFN.
+ S NOCC=$P(FINDPA(0),U,14)
+ S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
+ F TF=0,1 D
+ . S DFN=0
+ . F  S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN=""  D
+ .. K TLIST
+ .. S ITEM=""
+ .. F  S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM=""  D
+ ... S NFOUND=""
+ ... F  S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND=""  D
+ .... S FILENUM=""
+ .... F  S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM=""  D
+ ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
+ ..... S DATE=+$P(TEMP,U,3)
+ ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
+ .. S DATE="",NFOUND=0
+ .. F  S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC)  D
+ ... S ITEM=""
+ ... F  S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC)  D
+ .... S IND=""
+ .... F  S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC)  D
+ ..... S FILENUM=""
+ ..... F  S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC)  D
+ ...... S NFOUND=NFOUND+1
+ ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
+ K ^TMP($J,TGLIST)
+ Q
+ ;
+ ;===============================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms.
+ N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,NOINDEX,PFINDPA,POI
+ N RXTYL,TEMP,TFINDING,TFINDPA
+ N DATEORDR,NOCC,SDIR
+ S NOINDEX=0
+ I $G(^PXRMINDX(52,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
+ . S NOINDEX=1
+ I $G(^PXRMINDX(55,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
+ . S NOINDEX=1
+ ;Set NOCC and SDIR.
+ S NOCC=$P(FINDPA(0),U,14)
+ I NOCC="" S NOCC=1
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ S DRUGIEN=""
+ F  S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0  D
+ . ;DBIA #221
+ . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0  D
+ .. S TFIEVAL(TFINDING)=0
+ .. I NOINDEX Q
+ .. K DTERM,DTFIEVAL,PFINDPA,TFINDPA
+ .. S DTERM(0)="DTERM",DTERM("IEN")=0
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ ..;Determine where we search.
+ .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
+ .. I $D(RXTYL("I")) D
+ ... M DTERM(20,1)=TERMARR(20,TFINDING)
+ ... S $P(DTERM(20,1,0),U,1)=DRUGIEN_";PS(55,"
+ ... S DTERM("E","PS(55,",DRUGIEN,1)=""
+ .. I $D(RXTYL("N")),POI'="" D
+ ... M DTERM(20,2)=TERMARR(20,TFINDING)
+ ... S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA,"
+ ... S DTERM("E","PS(55NVA,",POI,2)=""
+ .. I $D(RXTYL("O")) D
+ ... M DTERM(20,3)=TERMARR(20,TFINDING)
+ ... S $P(DTERM(20,3,0),U,1)=DRUGIEN_";PSRX("
+ ... S DTERM("E","PSRX(",DRUGIEN,3)=""
+ .. D IEVALTER^PXRMTERM(DFN,.PFINDPA,.DTERM,TFINDING,.DTFIEVAL)
+ .. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR)
+ .. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL)
+ .. I TFIEVAL(TFINDING) S TFIEVAL(TFINDING,"DISPENSE DRUG")=DRUGIEN
+ Q
+ ;
+ ;===============================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N DRUG,DRUGIEN,IND,FTYPE,NAME,PFIEVAL,TEMP
+ S DRUGIEN=IFIEVAL("DISPENSE DRUG")
+ ;DBIA #10043
+ S DRUG=$P(^PSDRUG(DRUGIEN,0),U,1)
+ S NAME="Drug: "_DRUG_" = "
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S TEMP=IFIEVAL(IND,"FINDING")
+ . S FTYPE=$P(TEMP,";",2)
+ . K PFIEVAL M PFIEVAL=IFIEVAL(IND)
+ . S PFIEVAL("DISPENSE DRUG")=DRUG
+ . I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
+ . I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
+ . I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;===============================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ N DRUG,FTYPE,IND,PFIEVAL,TEMP,TEXTOUT
+ ;DBIA #10043
+ S DRUG=$P(^PSDRUG(IFIEVAL("DISPENSE DRUG"),0),U,1)
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S TEMP=IFIEVAL(IND,"FINDING")
+ . S FTYPE=$P(TEMP,";",2)
+ . K PFIEVAL M PFIEVAL=IFIEVAL(IND)
+ . S PFIEVAL("DISPENSE DRUG")=DRUG
+ . I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
+ . I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
+ . I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m

@@ -1 @@
-PXRMEDIT        ; SLC/PKR - Clinical Reminder edit driver. ;06/04/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-EDIT(ROOT,IENN) ;Call the appropriate edit routine.
-        ;Reminder location list
-        I ROOT="^PXRMD(810.9," D EDIT^PXRMLLED(ROOT,IENN) Q
-        ;
-        ;Taxonomy
-        I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q
-        ;
-        ;Reminder term
-        I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q
-        ;
-        ;Reminder definition
-        I ROOT="^PXD(811.9," D
-        .;Build list of finding types for finding edit
-        . N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
-        .;Edit reminder
-        . D ALL^PXRMREDT(ROOT,IENN) Q
-        Q
-        ;
+PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;05/18/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+EDIT(ROOT,IENN) ;Call the appropriate edit routine.
+ ;Taxonomy
+ I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q
+ ;
+ ;Reminder term
+ I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q
+ ;
+ ;Reminder
+ I ROOT="^PXD(811.9," D
+ .;Build list of finding types for finding edit
+ . N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
+ .;Edit reminder
+ . D ALL^PXRMREDT(ROOT,IENN) Q
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m

@@ -1 @@
-PXRMENOD        ; SLC/PKR - Clinical Reminders "E" node routines. ;12/13/2006
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;========================================================
-KENODE(X,DA,FILENUM)    ;Kill the enode in the finding multiple for definitions
-        ;and terms.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        N DAS,GLOBAL,IEN
-        S IEN=$P(X,";",1)
-        S GLOBAL=$P(X,";",2)
-        I GLOBAL="LAB(60," D
-        . N SUB
-        .;DBIA #91-A
-        . S SUB=$P(^LAB(60,IEN,0),U,4)
-        . I SUB="CH" Q
-        . I (SUB="BB")!(SUB="WK") S IEN="" Q
-        . I SUB="MI" S IEN="M;T;"_IEN Q
-        .;All other SUB values: AU, CY, EM, SP
-        . S IEN="A;T;"_IEN
-        S DAS=IEN
-        I DAS="" Q
-        I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)
-        I FILENUM=811.9 K ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)
-        Q
-        ;
-        ;========================================================
-SENODE(X,DA,FILENUM)    ;Set the enode in the finding multiple for definitions
-        ;and terms.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        N DAS,GLOBAL,IEN,NAME
-        S IEN=$P(X,";",1)
-        S GLOBAL=$P(X,";",2)
-        I GLOBAL="LAB(60," D
-        . N SUB
-        .;DBIA #91-A
-        . S SUB=$P(^LAB(60,IEN,0),U,4)
-        . I SUB="CH" Q
-        . I (SUB="BB")!(SUB="WK") S IEN="" Q
-        . I SUB="MI" S IEN="M;T;"_IEN Q
-        .;All other SUB values: AU, CY, EM, SP
-        . S IEN="A;T;"_IEN
-        S DAS=IEN
-        I DAS="" Q
-        S NAME=""
-        I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
-        I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
-        Q
-        ;
+PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;04/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;========================================================
+KENODE(X,DA,FILENUM) ;Kill the enode in the finding multiple for definitions
+ ;and terms.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ N DAS,GLOBAL,IEN
+ S IEN=$P(X,";",1)
+ S GLOBAL=$P(X,";",2)
+ I GLOBAL="LAB(60," D
+ . N SUB
+ .;DBIA #91-A
+ . S SUB=$P(^LAB(60,IEN,0),U,4)
+ . I SUB="CH" Q
+ . I (SUB="BB")!(SUB="WK") S IEN="" Q
+ . I SUB="MI" S IEN="M;T;"_IEN Q
+ .;All other SUB values: AU, CY, EM, SP
+ . S IEN="A;T;"_IEN
+ S DAS=IEN
+ I DAS="" Q
+ I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)
+ I FILENUM=811.9 K ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)
+ Q
+ ;
+ ;========================================================
+SENODE(X,DA,FILENUM) ;Set the enode in the finding multiple for definitions
+ ;and terms.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ N DAS,GLOBAL,IEN
+ S IEN=$P(X,";",1)
+ S GLOBAL=$P(X,";",2)
+ I GLOBAL="LAB(60," D
+ . N SUB
+ .;DBIA #91-A
+ . S SUB=$P(^LAB(60,IEN,0),U,4)
+ . I SUB="CH" Q
+ . I (SUB="BB")!(SUB="WK") S IEN="" Q
+ . I SUB="MI" S IEN="M;T;"_IEN Q
+ .;All other SUB values: AU, CY, EM, SP
+ . S IEN="A;T;"_IEN
+ S DAS=IEN
+ I DAS="" Q
+ I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=""
+ I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m

@@ -1 @@
-PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;07/17/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM EXTRACT DEFINITIONS
-START   N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
-        S X="IORESET"
-        D ENDR^%ZISS
-        S VALMCNT=0
-        D EN^VALM("PXRM EXTRACT DEFINITIONS")
-        Q
-        ;
-BLDLIST ;Build workfile
-        K ^TMP("PXRMEPM",$J)
-        N IEN,IND,PLIST
-        D LIST^PXRMETM("PXRMEPM",.VALMCNT)
-        Q
-        ;
-ENTRY   ;Entry code
-        D BLDLIST,XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMEPM",$J)
-        K ^TMP("PXRMEPMH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="Q"
-        Q
-        ;
-HDR     ; Header code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,SUB,XQORM
-        S SUB="PXRMEPMH"
-        D EN^VALM("PXRM EXTRACT HELP")
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-PEXIT   ;PXRM EXCH MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT DEFINITION SELECT ENTRY",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
-XSEL    ;PXRM EXTRACT DEFINITION SELECT ENTRY validation
-        N SEL,IEN
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;
-        ;Get the list ien.
-        S IEN=^TMP("PXRMEPM",$J,"SEL",SEL)
-        ;Display/Edit Extract Definition
-        D START^PXRMEPED(IEN)
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Select DE to display or edit a definition."
-        .S HTEXT(2)="Select ED to edit a definition"
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-EPADD   ;Add Rule Option
-        ;Reset Screen Mode
-        W IORESET
-        ;
-        ;Add Rule
-        D ADD^PXRMEPED
-        ;
-        ;Rebuild Workfile
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-EPINQ   ;Definition Inquiry - PXRM EXTRACT DEFINITION DISPLAY/EDIT entry 
-        N IND,LRIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the ien.
-        .S LRIEN=^TMP("PXRMEPM",$J,"SEL",IND)
-        .D START^PXRMEPED(LRIEN)
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-PPLR    ;Display rule set components 
-        ;used by [PXRM EXTRACT DEFINITION] template)
-        N ACT,DATA,FIRST,IEN,LRDATA,LRIEN,SEQ,SUB
-        S IEN=$P(X,U,2) Q:'IEN
-        W !," Description: ",$P($G(^PXRM(810.4,IEN,0)),U,2)
-        S SEQ="",FIRST=1
-        F  S SEQ=$O(^PXRM(810.4,IEN,30,"B",SEQ)) Q:'SEQ  D
-        .S SUB=$O(^PXRM(810.4,IEN,30,"B",SEQ,"")) Q:'SUB
-        .S DATA=$G(^PXRM(810.4,IEN,30,SUB,0)) Q:DATA=""
-        .S LRIEN=$P(DATA,U,2) Q:LRIEN=""
-        .S ACT=$P(DATA,U,3),LRDATA=$G(^PXRM(810.4,LRIEN,0))
-        .I FIRST W !!,?2,"List Rules:" S FIRST=0
-        .W !,?2,SEQ,?7,$P(LRDATA,U),?66
-        .W $S(ACT="A":"ADD PATIENT",ACT="R":"REMOVE PATIENT",ACT="F":"INSERT FINDING",1:"SELECT PATIENT")
-        .;Display List Rule fields
-        .D LROUT^PXRMLRED(LRIEN,23)
-        .W !
-        Q
-        ;
-PPFR    ;Display counting rules and count type 
-        ;used by [PXRM EXTRACT DEFINITION] template)
-        W !
-        N DATA,GIEN,GSTATUS,IEN,SEQ,SUB
-        S IEN=$P(X,U,3) Q:'IEN
-        S SEQ=""
-        F  S SEQ=$O(^PXRM(810.7,IEN,10,"B",SEQ)) Q:SEQ=""  D
-        .S SUB=$O(^PXRM(810.7,IEN,10,"B",SEQ,"")) Q:'SUB
-        .S DATA=$G(^PXRM(810.7,IEN,10,SUB,0)) Q:DATA=""
-        .S GIEN=$P(DATA,U,2) Q:GIEN=""
-        .S GSTATUS=$P(DATA,U,3)
-        .;Get counting groups
-        .N CTYP,CTXT,DATA,EXCL,FIRST,GNAME,PNAME,TIEN,TNAME,GSEQ,GSUB
-        .S DATA=$G(^PXRM(810.8,GIEN,0)),GNAME=$P(DATA,U)
-        .S CTYP=$P(DATA,U,3),PNAME=$P(DATA,U,2),GSEQ="",FIRST=1
-        .S CTXT=$$TXT(CTYP,GSTATUS)
-        .F  S GSEQ=$O(^PXRM(810.8,GIEN,10,"B",GSEQ)) Q:GSEQ=""  D
-        ..S GSUB=$O(^PXRM(810.8,GIEN,10,"B",GSEQ,"")) Q:'GSUB
-        ..S DATA=$G(^PXRM(810.8,GIEN,10,GSUB,0)) Q:DATA=""
-        ..S TIEN=$P(DATA,U,2) Q:TIEN=""
-        ..S EXCL=$P(DATA,U,3) Q:EXCL="E"
-        ..S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U)
-        ..I FIRST D
-        ...W !,?14,SEQ
-        ...W ?18,"Counting Group: ",GNAME
-        ...W !,?18,$$TXT(CTYP,GSTATUS)
-        ...W !,?23,"Terms:" S FIRST=0
-        ..W ?30,TNAME,!
-        Q
-        ;
-SCREEN  ;Screen for 810.210 field .02
-        S DIC("S")="I $P(^(0),U,3)=3"
-        Q
-        ;
-TXT(COUNT,COHORT)       ;Text to describe group
-        N TXT
-        ;Determine count type
-        I COUNT="MRFP" S TXT="Most recent finding patient counts for "
-        I COUNT="MRF" S TXT="Most recent finding counts for "
-        I COUNT="UR" S TXT="Utilization in period finding counts for "
-        ;Error
-        I $G(TXT)="" Q "Unknown count type - error"
-        ;Determine cohort
-        S TXT=TXT_$S(COHORT="A":"APPLICABLE",1:"TOTAL")_" patients"
-        Q TXT
+PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;06/21/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM EXTRACT DEFINITIONS
+START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+ S X="IORESET"
+ D ENDR^%ZISS
+ S VALMCNT=0
+ D EN^VALM("PXRM EXTRACT DEFINITIONS")
+ Q
+ ;
+BLDLIST ;Build workfile
+ K ^TMP("PXRMEPM",$J)
+ N IEN,IND,PLIST
+ D LIST^PXRMETM(.PLIST,.IEN)
+ M ^TMP("PXRMEPM",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMEPM",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
+ENTRY ;Entry code
+ D BLDLIST,XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMEPM",$J)
+ K ^TMP("PXRMEPMH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
+HDR ; Header code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMEPMH"
+ D EN^VALM("PXRM EXTRACT HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+PEXIT ;PXRM EXCH MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT DEFINITION SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM EXTRACT DEFINITION SELECT ENTRY validation
+ N SEL,IEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the list ien.
+ S IEN=^TMP("PXRMEPM",$J,"IDX",SEL,SEL)
+ ;Display/Edit Extract Definition
+ D START^PXRMEPED(IEN)
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Select DE to display or edit a definition."
+ .S HTEXT(2)="Select ED to edit a definition"
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+EPADD ;Add Rule Option
+ ;
+ ;Reset Screen Mode
+ W IORESET
+ ;
+ ;Add Rule
+ D ADD^PXRMEPED
+ ;
+ ;Rebuild Workfile
+ D BLDLIST
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+EPINQ ;Definition Inquiry - PXRM EXTRACT DEFINITION DISPLAY/EDIT entry 
+ N IND,LRIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LRIEN=^TMP("PXRMEPM",$J,"IDX",IND,IND)
+ .D START^PXRMEPED(LRIEN)
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+PPLR ;Display rule set components 
+ ;used by [PXRM EXTRACT DEFINITION] template)
+ N ACT,DATA,FIRST,IEN,LRDATA,LRIEN,SEQ,SUB
+ S IEN=$P(X,U,2) Q:'IEN
+ W !," Description: ",$P($G(^PXRM(810.4,IEN,0)),U,2)
+ S SEQ="",FIRST=1
+ F  S SEQ=$O(^PXRM(810.4,IEN,30,"B",SEQ)) Q:'SEQ  D
+ .S SUB=$O(^PXRM(810.4,IEN,30,"B",SEQ,"")) Q:'SUB
+ .S DATA=$G(^PXRM(810.4,IEN,30,SUB,0)) Q:DATA=""
+ .S LRIEN=$P(DATA,U,2) Q:LRIEN=""
+ .S ACT=$P(DATA,U,3),LRDATA=$G(^PXRM(810.4,LRIEN,0))
+ .I FIRST W !!,?2,"List Rules:" S FIRST=0
+ .W !,?2,SEQ,?7,$P(LRDATA,U),?66
+ .W $S(ACT="A":"ADD PATIENT",ACT="R":"REMOVE PATIENT",ACT="F":"INSERT FINDING",1:"SELECT PATIENT")
+ .;Display List Rule fields
+ .D LROUT^PXRMLRED(LRIEN,23)
+ .W !
+ Q
+ ;
+PPFR ;Display counting rules and count type 
+ ;used by [PXRM EXTRACT DEFINITION] template)
+ W !
+ N DATA,GIEN,GSTATUS,IEN,SEQ,SUB
+ S IEN=$P(X,U,3) Q:'IEN
+ S SEQ=""
+ F  S SEQ=$O(^PXRM(810.7,IEN,10,"B",SEQ)) Q:SEQ=""  D
+ .S SUB=$O(^PXRM(810.7,IEN,10,"B",SEQ,"")) Q:'SUB
+ .S DATA=$G(^PXRM(810.7,IEN,10,SUB,0)) Q:DATA=""
+ .S GIEN=$P(DATA,U,2) Q:GIEN=""
+ .S GSTATUS=$P(DATA,U,3)
+ .;Get counting groups
+ .N CTYP,CTXT,DATA,EXCL,FIRST,GNAME,PNAME,TIEN,TNAME,GSEQ,GSUB
+ .S DATA=$G(^PXRM(810.8,GIEN,0)),GNAME=$P(DATA,U)
+ .S CTYP=$P(DATA,U,3),PNAME=$P(DATA,U,2),GSEQ="",FIRST=1
+ .S CTXT=$$TXT(CTYP,GSTATUS)
+ .F  S GSEQ=$O(^PXRM(810.8,GIEN,10,"B",GSEQ)) Q:GSEQ=""  D
+ ..S GSUB=$O(^PXRM(810.8,GIEN,10,"B",GSEQ,"")) Q:'GSUB
+ ..S DATA=$G(^PXRM(810.8,GIEN,10,GSUB,0)) Q:DATA=""
+ ..S TIEN=$P(DATA,U,2) Q:TIEN=""
+ ..S EXCL=$P(DATA,U,3) Q:EXCL="E"
+ ..S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U)
+ ..I FIRST D
+ ...W !,?14,SEQ
+ ...W ?18,"Counting Group: ",GNAME
+ ...W !,?18,$$TXT(CTYP,GSTATUS)
+ ...W !,?23,"Terms:" S FIRST=0
+ ..W ?30,TNAME,!
+ Q
+ ;
+SCREEN ;Screen for 810.210 field .02
+ S DIC("S")="I $P(^(0),U,3)=3"
+ Q
+ ;
+TXT(COUNT,COHORT) ;Text to describe group
+ N TXT
+ ;Determine count type
+ I COUNT="MRFP" S TXT="Most recent finding patient counts for "
+ I COUNT="MRF" S TXT="Most recent finding counts for "
+ I COUNT="UR" S TXT="Utilization in period finding counts for "
+ ;Error
+ I $G(TXT)="" Q "Unknown count type - error"
+ ;Determine cohort
+ S TXT=TXT_$S(COHORT="A":"APPLICABLE",1:"TOTAL")_" patients"
+ Q TXT

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m

@@ -1 @@
-PXRMETCO        ; SLC/PJH - QUERI Extract Compliance Report ;03/27/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;
-ADHOC(IEN,PXRMSTRT,PXRMSTOP)    ;Ad Hoc Conformance Report
-        D DUMMY1^PXRMRUTL
-        Q
-        ;
-        D JOB
-        Q
-        ;
-        ;BOOKMARK - cloned from PXRMETX, needs modifying to avoid patient list
-        ;update. Build ^TMP("PXRMETX",$J) for report
-        ;
-REPORT  ;Initialise
-        K ^TMP("PXRMETX",$J)
-        ;Workfile node for ^TMP
-        S PXRMNODE="PXRMRULE"
-        ;Get details from parameter file
-        N DATA,DATES,LIST,NAME,PARTYPE,TEXT
-        ;N PERIOD,TEXT,YEAR
-        S DATA=$G(^PXRM(810.2,IEN,0))
-        ;
-        ;Determine Extract Name and period
-        S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
-        ;S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
-        ;Calculate report period start and end dates
-        ;D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
-        ;Determine output name for patient list and extract summary
-        S DATES=$$FMTE^XLFDT(PXRMSTRT)_" - "_$$FMTE^XLFDT(PXRMSTOP)
-        ;
-        ;Bookmark - Needs inventive patient list names
-        S LIST=NAME_" REPORT "_DATES
-        ;Process (single) Denominator rule into patient list
-        N INDP,INTP,SEQ,SUB,SUFFIX
-        S SEQ=""
-        F  S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ  D
-        .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
-        .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
-        .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
-        .S SUFFIX=$P(DATA,U,3)
-        .I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ
-        .S INDP=+$P(DATA,U,4)
-        .S INTP=+$P(DATA,U,5)
-        .;Create new patient list
-        .S PXRMLIST=$$CRLST^PXRMRUL1(LIST_" "_SUFFIX) Q:'PXRMLIST
-        .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,INDP,INTP)
-        .;Clear ^TMP lists created for rule
-        .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
-        .;Process reminders
-        .D REM^PXRMETXR(SUB,PXRMLIST)
-        ;
-        ;Bookmark - Report stuff goes here
-        ;Update totals section
-        N APPL,DUE,DATA,ETYP,EVAL
-        N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FIND,FNAPPL,FNDUE,FSEQ
-        N NAPPL,NDUE,PXRMLIST,RCNT,RIEN,RSEQ,SEQ
-        S SEQ=0,CNT=1
-        F  S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:'SEQ  D
-        .S RCNT=0,RSEQ=0
-        .F  S RCNT=$O(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'RCNT  D
-        ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'DATA
-        ..S RIEN=$P(DATA,U),PXRMLIST=$P(DATA,U,5)
-        ..S EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3),DUE=$P(DATA,U,4)
-        ..S NAPPL=EVAL-APPL,NDUE=APPL-DUE
-        ..S CNT=CNT+1,RSEQ=RSEQ+1
-        ..;bookmark - write patient line
-        ..;For each count type
-        ..S ETYP="",FCNT=CNT
-        ..F  S ETYP=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP)) Q:ETYP=""  D
-        ...;For each term
-        ...S FIND=0,FSEQ=0
-        ...F  S FIND=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)) Q:FIND=""  D
-        ....;Update finding totals
-        ....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)),FCNT=FCNT+1
-        ....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FDUE=$P(FDATA,U,4)
-        ....S FNAPPL=FEVAL-FAPPL,FNDUE=FAPPL-FDUE
-        ....S FSEQ=FSEQ+1,FGNAM=$P(DATA,U,9)
-        ....;Bookmark - write finding line
-        ..;Update CNT
-        ..S CNT=FCNT
-        Q
-        ;
-        ;Determine whether the report should be queued.
-JOB     ;
-        N %ZIS,ZTDESC,ZTSAVE,ZTRTN,ZTSK
-        S DBDUZ=DUZ
-        D SAVE^PXRMXQUE
-        S %ZIS="Q"
-        S ZTDESC="QUERI Compliance Report - print"
-        S ZTRTN="REPORT^PXRMETCO"
-        S ZTSK=1
-        S PXRMQUE=0
-        S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
-        I PXRMQUE=1 G EXIT
-        I PXRMQUE>0 S ^XTMP(PXRMXTMP,"PRZTSK")=PXRMQUE
-        Q
-        ;
-EXIT    ;Clean things up.
-        D ^%ZISC
-        D HOME^%ZIS
-        K IO("Q")
-        K DIRUT,DTOUT,DUOUT,POP,ZTREQ
-        I $D(ZTSK) D KILL^%ZTLOAD
-        K ZTSK,ZTQUEUED
-        K ^TMP("PXRMXTR",$J)
-        Q
-        ;
-SAVE    ;Save the variables for queing.
-        S ZTSAVE("IEN")=""
-        S ZTSAVE("PXRMSTRT")=""
-        S ZTSAVE("PXRMSTOP")=""
-        Q
-        ;
-        ;
-QUE     ;BOOKMARK - NOT USED
-        ;Queue the MST synchronization job.
-        N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        W !,"Queue the Clinical Reminders MST synchronization."
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DTOUT)!$D(DUOUT) Q
-        S SDTIME=Y
-        K DIR
-        S DIR(0)="YA"
-        S DIR("A")="Do you want to run the MST synchronization at the same time every day? "
-        S DIR("B")="Y"
-        D ^DIR
-        I $D(DTOUT)!$D(DUOUT) Q
-        I Y S STIME="1."_$P(SDTIME,".",2)
-        E  S STIME=-1
-        ;
-        ;Put the task into the queue.
-        K ZTSAVE
-        ;S ZTSAVE("START")=SDTIME
-        S ZTSAVE("STIME")=STIME
-        S ZTRTN="SYNCH^PXRMMST"
-        S ZTDESC="Clinical Reminders MST synchronization job"
-        S ZTDTH=SDTIME
-        S ZTIO=""
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued."
-        Q
+PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;01/19/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;
+ADHOC(IEN,PXRMSTRT,PXRMSTOP) ;Ad Hoc Conformance Report
+ D DUMMY1^PXRMRUTL
+ Q
+ ;
+ D JOB
+ Q
+ ;
+ ;BOOKMARK - cloned from PXRMETX, needs modifying to avoid patient list
+ ;update. Build ^TMP("PXRMETX",$J) for report
+ ;
+REPORT ;Initialise
+ K ^TMP("PXRMETX",$J)
+ ;Workfile node for ^TMP
+ S PXRMNODE="PXRMRULE"
+ ;Get details from parameter file
+ N DATA,DATES,LIST,NAME,PARTYPE,TEXT
+ ;N PERIOD,TEXT,YEAR
+ S DATA=$G(^PXRM(810.2,IEN,0))
+ ;
+ ;Determine Extract Name and period
+ S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
+ ;S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
+ ;Calculate report period start and end dates
+ ;D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
+ ;Determine output name for patient list and extract summary
+ S DATES=$$FMTE^XLFDT(PXRMSTRT)_" - "_$$FMTE^XLFDT(PXRMSTOP)
+ ;
+ ;Bookmark - Needs inventive patient list names
+ S LIST=NAME_" REPORT "_DATES
+ ;Process (single) Denominator rule into patient list
+ N SEQ,SUB,SUFFIX
+ S SEQ=""
+ F  S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ  D
+ .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
+ .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
+ .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
+ .S SUFFIX=$P(DATA,U,3)
+ .I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ
+ .;Create new patient list
+ .S PXRMLIST=$$CRLST^PXRMRULE(LIST_" "_SUFFIX) Q:'PXRMLIST
+ .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,"","")
+ .;Clear ^TMP lists created for rule
+ .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
+ .;Process reminders
+ .D REM^PXRMETXR(SUB,PXRMLIST)
+ ;
+ ;Bookmark - Report stuff goes here
+ ;Update totals section
+ N APPL,DUE,DATA,ETYP,EVAL
+ N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FIND,FNAPPL,FNDUE,FSEQ
+ N NAPPL,NDUE,PXRMLIST,RCNT,RIEN,RSEQ,SEQ
+ S SEQ=0,CNT=1
+ F  S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:'SEQ  D
+ .S RCNT=0,RSEQ=0
+ .F  S RCNT=$O(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'RCNT  D
+ ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'DATA
+ ..S RIEN=$P(DATA,U),PXRMLIST=$P(DATA,U,5)
+ ..S EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3),DUE=$P(DATA,U,4)
+ ..S NAPPL=EVAL-APPL,NDUE=APPL-DUE
+ ..S CNT=CNT+1,RSEQ=RSEQ+1
+ ..;bookmark - write patient line
+ ..;For each count type
+ ..S ETYP="",FCNT=CNT
+ ..F  S ETYP=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP)) Q:ETYP=""  D
+ ...;For each term
+ ...S FIND=0,FSEQ=0
+ ...F  S FIND=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)) Q:FIND=""  D
+ ....;Update finding totals
+ ....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)),FCNT=FCNT+1
+ ....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FDUE=$P(FDATA,U,4)
+ ....S FNAPPL=FEVAL-FAPPL,FNDUE=FAPPL-FDUE
+ ....S FSEQ=FSEQ+1,FGNAM=$P(DATA,U,9)
+ ....;Bookmark - write finding line
+ ..;Update CNT
+ ..S CNT=FCNT
+ Q
+ ;
+ ;Determine whether the report should be queued.
+JOB ;
+ N %ZIS,ZTDESC,ZTSAVE,ZTRTN,ZTSK
+ S DBDUZ=DUZ
+ D SAVE^PXRMXQUE
+ S %ZIS="Q"
+ S ZTDESC="QUERI Compliance Report - print"
+ S ZTRTN="REPORT^PXRMETCO"
+ S ZTSK=1
+ S PXRMQUE=0
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
+ I PXRMQUE=1 G EXIT
+ I PXRMQUE>0 S ^XTMP(PXRMXTMP,"PRZTSK")=PXRMQUE
+ Q
+ ;
+EXIT ;Clean things up.
+ D ^%ZISC
+ D HOME^%ZIS
+ K IO("Q")
+ K DIRUT,DTOUT,DUOUT,POP,ZTREQ
+ I $D(ZTSK) D KILL^%ZTLOAD
+ K ZTSK,ZTQUEUED
+ K ^TMP("PXRMXTR",$J)
+ Q
+ ;
+SAVE ;Save the variables for queing.
+ S ZTSAVE("IEN")=""
+ S ZTSAVE("PXRMSTRT")=""
+ S ZTSAVE("PXRMSTOP")=""
+ Q
+ ;
+ ;
+QUE ;BOOKMARK - NOT USED
+ ;Queue the MST synchronization job.
+ N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ W !,"Queue the Clinical Reminders MST synchronization."
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DTOUT)!$D(DUOUT) Q
+ S SDTIME=Y
+ K DIR
+ S DIR(0)="YA"
+ S DIR("A")="Do you want to run the MST synchronization at the same time every day? "
+ S DIR("B")="Y"
+ D ^DIR
+ I $D(DTOUT)!$D(DUOUT) Q
+ I Y S STIME="1."_$P(SDTIME,".",2)
+ E  S STIME=-1
+ ;
+ ;Put the task into the queue.
+ K ZTSAVE
+ ;S ZTSAVE("START")=SDTIME
+ S ZTSAVE("STIME")=STIME
+ S ZTRTN="SYNCH^PXRMMST"
+ S ZTDESC="Clinical Reminders MST synchronization job"
+ S ZTDTH=SDTIME
+ S ZTIO=""
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued."
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m

@@ -1 @@
-PXRMETH ; SLC/PJH - Reminder Extract History ;10/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM EXTRACT HISTORY
-START(EDIEN)    ;
-        ;EDIEN is the extract definition IEN.
-        N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
-        ;Details of last run
-        N DATA,NPERIOD,NSDATE,NTAS,PXRMVIEW
-        S DATA=$G(^PXRM(810.2,EDIEN,0))
-        S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7)
-        ;Default view is in date created order
-        S PXRMVIEW="D"
-        S X="IORESET"
-        D ENDR^%ZISS
-        S VALMCNT=0
-        D EN^VALM("PXRM EXTRACT HISTORY")
-        Q
-        ;
-DELETE  ;Delete an extract, called by protocol PXRM EXTRACT SUMMARY DELETE.
-        N CLASS,IEN,IENLIST,IND
-        S IENLIST=$$LMSEL
-        F IND=1:1:$L(IENLIST,U) D
-        .S IEN=$P(IENLIST,U,IND)
-        .D DELETE^PXRMETXU(IEN)
-        ;Rebuild workfile
-        D BLDLIST^PXRMETH1(EDIEN)
-        ;Refresh
-        S VALMBCK="R"
-        Q
-        ;
-ENTRY   ;Entry code
-        D BLDLIST^PXRMETH1(EDIEN),XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMETH",$J)
-        K ^TMP("PXRMETHH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="Q"
-        Q
-        ;
-EXTRACT(EDIEN)  ;Run Extract/Transmission
-        ;Reset screen mode
-        W IORESET
-        ;Refresh on exit
-        S VALMBCK="R"
-        ;
-        ;Get details from parameter file
-        N ANS,DATA,DUOUT,DTOUT,EDATE,EXSUMPUG,FREQ,MODE
-        N NAME,NAT,NEXT,PLISTPUG,RTN,REPL,STATUS,SNEXT,TEXT,XMIT
-        S DATA=$G(^PXRM(810.2,EDIEN,0))
-        S NAT=$P($G(^PXRM(810.2,EDIEN,100)),U)
-        ;Determine Extract Name and Frequency
-        S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX"
-        ;Save next scheduled extract
-        S SNEXT=NEXT
-        ;Select extract period
-EXSEL   D SELECT(FREQ,.NEXT) Q:$D(DUOUT)!$D(DTOUT)
-        ;Warn if period is still open
-        D WARN(NEXT,.STATUS)
-        ;Option to continue
-        S TEXT="Are you sure you want to run a "_NAME_" extract for "_$TR(NEXT,"/"," ")
-SURE    ;
-        S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:$D(DUOUT)!$D(DTOUT)  Q:'ANS
-        ;Purge options
-PLIST   ;
-        S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5)
-        G:$D(DUOUT) SURE Q:$D(DTOUT)
-        S EXSUMPUG="N" D ASK^PXRMXD(.EXSUMPUG,"Purge Extract Summary after 5 years?: ",5)
-        G:$D(DUOUT) PLIST Q:$D(DTOUT)
-        ;Option to transmit
-        S TEXT="Transmit extract results to AAC"
-        I NAT="N" S XMIT=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
-        E  S XMIT=0
-        ;Option to replace scheduled run
-        S REPL=0
-        I XMIT,SNEXT=NEXT,STATUS="COMPLETE" D  Q:$D(DUOUT)!$D(DTOUT)
-        .S TEXT="Does this extract replace the scheduled extract"
-        .S REPL=$$ASKYN^PXRMEUT("N",TEXT,RTN,4) Q:$D(DUOUT)!$D(DTOUT)
-        ;
-        ;Note that the manual extract does not update 810.2
-        ;exept if the selected period is the same as the scheduled
-        ;period AND this period is complete
-        ;
-        ;Default is to extract and transmit and not update 810.2
-        S MODE=2 I 'XMIT S MODE=3
-        ;Update 810.2 if this extract is for current completed period
-        I REPL S MODE=0 I 'XMIT S MODE=1
-        ;
-        ;Extract/transmission run
-        N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
-        S ZTDESC="Reminder Extract "_NAME
-        S ZTRTN="RUN^PXRMETX(EDIEN,NEXT,MODE,EXSUMPUG)"
-        S ZTSAVE("EDIEN")=""
-        S ZTSAVE("MODE")=""
-        S ZTSAVE("NEXT")=""
-        S ZTSAVE("PLISTPUG")=""
-        S ZTSAVE("EXSUMPUG")=""
-        S ZTIO=""
-        ;
-        ;Select and verify start date/time for task
-        N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        W !,"Queue a "_ZTDESC_" for "_NEXT
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DTOUT)!$D(DUOUT) Q
-        S SDTIME=Y
-        ;
-        ;Put the task into the queue.
-        S ZTDTH=SDTIME
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued." H 2
-        S VALMBCK="Q"
-        Q
-        ;
-HDR     ; Header code
-        N VIEW
-        S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
-        S VALMHDR(2)="          Extract Name: "_$P($G(^PXRM(810.2,EDIEN,0)),U)
-        S VALMHDR(3)="   Next Extract Period: "_NPERIOD
-        S VALMHDR(4)="      Scheduled to Run: "_$$FMTE^XLFDT(NSDATE,"5Z")
-        S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_"    View: "_VIEW
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,SUB,XQORM
-        S SUB="PXRMETHH"
-        D EN^VALM("PXRM EXTRACT HELP")
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-LMSEL() ;Return selection list
-        N IENLIST,IND,VALMY,XIEN
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q ""
-        S PXRMDONE=0,IENLIST=""
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the ien.
-        .S XIEN=^TMP("PXRMETH",$J,"SEL",IND)
-        .S IENLIST=$S(IENLIST'="":IENLIST_U_XIEN,1:XIEN)
-        Q IENLIST
-        ;
-PEXIT   ;PXRM EXCH MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        D XQORM
-        Q
-        ;
-SELECT(FREQ,SEL)        ;Select extract period
-        N BDATE,EDATE,DA,DIE,DIK,DIR,DR,FDATE,VALID,X
-        ;Get the new name.
-        F  D  Q:$D(DTOUT)!$D(DUOUT)  Q:SEL]""
-        .S DIR("A")="Select EXTRACT PERIOD "
-        .I FREQ="M" D
-        ..S DIR("A")=DIR("A")_"(Mnn/yyyy)"
-        ..S DIR(0)="F"_U_"7:8"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
-        .I FREQ="Q" D
-        ..S DIR("A")=DIR("A")_"(Qnn/yyyy)"
-        ..S DIR(0)="F"_U_"7:7"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
-        .I FREQ="Y" D
-        ..S DIR("A")=DIR("A")_"(yyyy)"
-        ..S DIR(0)="N"_U_"2000:2050"_U_"K:(X'?4N) X"
-        .;Default is next period
-        .S DIR("B")=NEXT
-        .W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
-        .;Calculate beginning and end dates for period
-        .S Y=$$UP^XLFSTR(Y) D CALC^PXRMEUT(Y,.BDATE,.EDATE)
-        .;Abort if period has not started
-        .I $$FMDIFF^XLFDT(BDATE,$$NOW^XLFDT)>0 D   Q
-        ..S FDATE=$$FMTE^XLFDT(BDATE,5)
-        ..W !,"ERROR -This period does not start until "_FDATE,*7
-        .S SEL=Y
-        Q
-        ;
-TLIST   ;Extract summary display
-        N IEN,IENLIST,IND
-        S IENLIST=$$LMSEL
-        F IND=1:1:$L(IENLIST,U) D
-        .S IEN=$P(IENLIST,U,IND)
-        .D START^PXRMETT(IEN)
-        .S VALMBCK="R"
-        S VALMBCK="R"
-        Q
-        ;
-TRANS   ;Run Transmission
-        N IEN,IENLIST,IND
-        S IENLIST=$$LMSEL
-        F IND=1:1:$L(IENLIST,U) D
-        .S IEN=$P(IENLIST,U,IND)
-        .I $P($G(^PXRMXT(810.3,IEN,100)),U)'="N" D  Q
-        ..W !,"Local extracts cannot be transmitted to AAC." H 2
-        .;Transmit extract summary
-        .N ANS,DUOUT,DTOUT,RTN,TEXT
-        .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
-        .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
-        .I ANS D TRANS^PXRMETX(IEN)
-        ;
-        ;Rebuild workfile
-        D BLDLIST^PXRMETH1(EDIEN)
-        ;Refresh
-        S VALMBCK="R"
-        Q
-        ;
-TRHIST  ;Transmission History
-        N IEN,IENLIST,IND
-        S IENLIST=$$LMSEL
-        F IND=1:1:$L(IENLIST,U) D
-        .S IEN=$P(IENLIST,U,IND)
-        .D START^PXRMETHL(IEN)
-        S VALMBCK="R"
-        Q
-        ;
-VALID(FREQ,INP) ;Validate Period input
-        W !
-        N PERIOD,YEAR
-        ;Convert to upper case
-        S INP=$$UP^XLFSTR(INP)
-        ;General format
-        I $E(INP)'=FREQ D EN^DDIOL("Format should be "_FREQ_"nn/yyyy") Q 0
-        S PERIOD=$P(INP,"/"),YEAR=$P(INP,"/",2)
-        S PERIOD=$P(PERIOD,FREQ,2)
-        ;All runs
-        I (YEAR<2000)!(YEAR>2050) D EN^DDIOL("Year should be in range 2000-2050") Q 0
-        ;Quarterly run
-        I FREQ="Q",(PERIOD>4)!(PERIOD<1) D EN^DDIOL("Quarter should be in range 1-4") Q 0
-        ;Monthly run
-        I FREQ="M",(PERIOD>12)!(PERIOD<1) D EN^DDIOL("Month should be in range 1-12") Q 0
-        ;Otherwise
-        Q 1
-        ;
-VIEW    ;Select view
-        W IORESET
-        S VALMBCK="R"
-        N X,Y,CODE,DIR
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="S"_U_"D:Sort by Creation Date;"
-        S DIR(0)=DIR(0)_"P:Sort by Extract Period;"
-        S DIR("A")="TYPE OF VIEW"
-        S DIR("B")=$S(PXRMVIEW="P":"D",1:"P")
-        S DIR("?")="Select from the codes displayed. For detailed help type ??"
-        ;BOOKMARK - HELP NEEDS MOVING
-        S DIR("??")=U_"D HELP^PXRMSEL2(3)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        ;Change display type
-        S PXRMVIEW=Y
-        ;
-        ;Rebuild Workfile
-        D BLDLIST^PXRMETH1(EDIEN),HDR
-        Q
-        ;
-WARN(NEXT,STATUS)       ;Warn if period is not completed
-        N BDATE,EDATE,FDATE
-        ;Calculate beginning and end dates for period
-        D CALC^PXRMEUT(NEXT,.BDATE,.EDATE)
-        ;No warning if period end date is a prior date
-        I $$FMDIFF^XLFDT($$NOW^XLFDT,EDATE)>0 S STATUS="COMPLETE" Q
-        ;Else Format date
-        S FDATE=$$FMTE^XLFDT(EDATE,5),STATUS="INCOMPLETE"
-        ;And Warn that period end date is a future date
-        W !!,"WARNING -This period is not complete until "_FDATE
-        Q
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
-XSEL    ;PXRM EXTRACT HISTORY SELECT ENTRY validation
-        N SEL,PXRMSIEN
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;
-        ;Get the list ien.
-        ;S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
-        S PXRMSIEN=^TMP("PXRMETH",$J,"SEL",SEL)
-        ;
-        ;Full screen mode
-        D FULL^VALM1
-        ;
-        ;Options
-        N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="SBM"_U_"DE:Delete Extract;"
-        S DIR(0)=DIR(0)_"ES:Extract Summary;"
-        S DIR(0)=DIR(0)_"MT:Manual Transmission;"
-        S DIR(0)=DIR(0)_"TH:Transmission History;"
-        S DIR("A")="Select Action"
-        S DIR("B")="ES"
-        S DIR("?")="Select from the codes displayed. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMETH1(1)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
-        S OPTION=Y
-        ;
-        ;Delete an extract
-        I OPTION="DE" D
-        .D DELETE^PXRMETXU(PXRMSIEN)
-        .;Rebuild workfile
-        .D BLDLIST^PXRMETH1(PXRMSIEN)
-        .;Refresh
-        .S VALMBCK="R"
-        ;
-        ;Display Extract Summary
-        I OPTION="ES" D START^PXRMETT(PXRMSIEN)
-        ;
-        ;Transmission option
-        I OPTION="MT" D
-        .N ANS,DUOUT,DTOUT,RTN,TEXT
-        .I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D  Q
-        ..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
-        .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
-        .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
-        .I ANS D TRANS^PXRMETX(PXRMSIEN)
-        ;
-        ;Transmission History
-        I OPTION="TH" D START^PXRMETHL(PXRMSIEN)
-        ;
-        S VALMBCK="R"
-        Q
-        ;
+PXRMETH ; SLC/PJH - Reminder Extract History ;08/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM EXTRACT HISTORY
+START(IEN) ;
+ N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+ ;Details of last run
+ N DATA,NPERIOD,NSDATE,NTAS,PXRMVIEW
+ S DATA=$G(^PXRM(810.2,IEN,0))
+ S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7)
+ ;Default view is in date created order
+ S PXRMVIEW="D"
+ S X="IORESET"
+ D ENDR^%ZISS
+ S VALMCNT=0
+ D EN^VALM("PXRM EXTRACT HISTORY")
+ Q
+ ;
+ENTRY ;Entry code
+ D BLDLIST^PXRMETH1(IEN),XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMETH",$J)
+ K ^TMP("PXRMETHH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
+HDR ; Header code
+ N VIEW
+ S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
+ S VALMHDR(2)="          Extract Name: "_$P($G(^PXRM(810.2,IEN,0)),U)
+ S VALMHDR(3)="   Next Extract Period: "_NPERIOD
+ S VALMHDR(4)="      Scheduled to Run: "_NSDATE
+ S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_"    View: "_VIEW
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMETHH"
+ D EN^VALM("PXRM EXTRACT HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+PEXIT ;PXRM EXCH MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ D XQORM
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM EXTRACT HISTORY SELECT ENTRY validation
+ N SEL,PXRMSIEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the list ien.
+ S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
+ ;
+ ;Full screen mode
+ D FULL^VALM1
+ ;
+ ;Options
+ N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="SBM"_U_"ES:Extract Summary;"
+ S DIR(0)=DIR(0)_"MT:Manual Transmission;"
+ S DIR(0)=DIR(0)_"TH:Transmission History;"
+ S DIR("A")="Select Action"
+ S DIR("B")="ES"
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMETH1(1)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
+ S OPTION=Y
+ ;
+ ;Display Extract Summary
+ I OPTION="ES" D
+ .D START^PXRMETT(PXRMSIEN)
+ ;
+ ;Transmission option
+ I OPTION="MT" D
+ .N ANS,DUOUT,DTOUT,RTN,TEXT
+ .I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D  Q
+ ..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
+ .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
+ .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
+ .I ANS D TRANS^PXRMETX(PXRMSIEN)
+ ;
+ ;Transmission History
+ I OPTION="TH" D
+ .D START^PXRMETHL(PXRMSIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+EXTRACT(IEN) ;Run Extract/Transmission
+ ;
+ ;Reset screen mode
+ W IORESET
+ ;Refresh on exit
+ S VALMBCK="R"
+ ;
+ ;Get details from parameter file
+ N ANS,DATA,DUOUT,DTOUT,EDATE,EXSUMPUG,FREQ,MODE
+ N NAME,NAT,NEXT,PLISTPUG,RTN,REPL,STATUS,SNEXT,TEXT,XMIT
+ S DATA=$G(^PXRM(810.2,IEN,0))
+ S NAT=$P($G(^PXRM(810.2,IEN,100)),U)
+ ;Determine Extract Name and Frequency
+ S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX"
+ ;Save next scheduled extract
+ S SNEXT=NEXT
+ ;Select extract period
+EXSEL D SELECT(FREQ,.NEXT) Q:$D(DUOUT)!$D(DTOUT)
+ ;Warn if period is still open
+ D WARN(NEXT,.STATUS)
+ ;Option to continue
+ S TEXT="Are you sure you want to run a "_NAME_" extract for "_$TR(NEXT,"/"," ")
+SURE ;
+ S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:$D(DUOUT)!$D(DTOUT)  Q:'ANS
+ ;Purge options
+PLIST ;
+ S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5)
+ G:$D(DUOUT) SURE Q:$D(DTOUT)
+ S EXSUMPUG="N" D ASK^PXRMXD(.EXSUMPUG,"Purge Extract Summary after 5 years?: ",5)
+ G:$D(DUOUT) PLIST Q:$D(DTOUT)
+ ;Option to transmit
+ S TEXT="Transmit extract results to AAC"
+ I NAT="N" S XMIT=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
+ E  S XMIT=0
+ ;Option to replace scheduled run
+ S REPL=0
+ I XMIT,SNEXT=NEXT,STATUS="COMPLETE" D  Q:$D(DUOUT)!$D(DTOUT)
+ .S TEXT="Does this extract replace the scheduled extract"
+ .S REPL=$$ASKYN^PXRMEUT("N",TEXT,RTN,4) Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ ;Note that the manual extract does not update 810.2
+ ;exept if the selected period is the same as the scheduled
+ ;period AND this period is complete
+ ;
+ ;Default is to extract and transmit and not update 810.2
+ S MODE=2 I 'XMIT S MODE=3
+ ;Update 810.2 if this extract is for current completed period
+ I REPL S MODE=0 I 'XMIT S MODE=1
+ ;
+ ;Extract/transmission run
+ N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+ S ZTDESC="Reminder Extract "_NAME
+ S ZTRTN="RUN^PXRMETX(IEN,NEXT,MODE,EXSUMPUG)"
+ S ZTSAVE("IEN")=""
+ S ZTSAVE("MODE")=""
+ S ZTSAVE("NEXT")=""
+ S ZTSAVE("PLISTPUG")=""
+ S ZTSAVE("EXSUMPUG")=""
+ S ZTIO=""
+ ;
+ ;Select and verify start date/time for task
+ N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ W !,"Queue a "_ZTDESC_" for "_NEXT
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DTOUT)!$D(DUOUT) Q
+ S SDTIME=Y
+ ;
+ ;Put the task into the queue.
+ S ZTDTH=SDTIME
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued." H 2
+ ;
+ S VALMBCK="Q"
+ Q
+ ;
+SELECT(FREQ,SEL) ;Select extract period
+ ;
+ N BDATE,EDATE,DA,DIE,DIK,DIR,DR,FDATE,VALID,X
+ ;Get the new name.
+ F  D  Q:$D(DTOUT)!$D(DUOUT)  Q:SEL]""
+ .S DIR("A")="Select EXTRACT PERIOD "
+ .I FREQ="M" D
+ ..S DIR("A")=DIR("A")_"(Mnn/yyyy)"
+ ..S DIR(0)="F"_U_"7:8"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
+ .I FREQ="Q" D
+ ..S DIR("A")=DIR("A")_"(Qnn/yyyy)"
+ ..S DIR(0)="F"_U_"7:7"_U_"K:'$$VALID^PXRMETH(FREQ,X) X"
+ .I FREQ="Y" D
+ ..S DIR("A")=DIR("A")_"(yyyy)"
+ ..S DIR(0)="N"_U_"2000:2050"_U_"K:(X'?4N) X"
+ .;Default is next period
+ .S DIR("B")=NEXT
+ .W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)
+ .;Calculate beginning and end dates for period
+ .S Y=$$UP^XLFSTR(Y) D CALC^PXRMEUT(Y,.BDATE,.EDATE)
+ .;Abort if period has not started
+ .I $$FMDIFF^XLFDT(BDATE,$$NOW^XLFDT)>0 D   Q
+ ..S FDATE=$$FMTE^XLFDT(BDATE,5)
+ ..W !,"ERROR -This period does not start until "_FDATE,*7
+ .S SEL=Y
+ Q
+ ;
+TLIST ;Extract Totals
+ N IND,PXRMSIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .D START^PXRMETT(PXRMSIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+TRANS ;Run Transmission
+ N IND,PXRMXIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMXIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .I $P($G(^PXRMXT(810.3,PXRMXIEN,100)),U)'="N" D  Q
+ ..W !,"Local extracts cannot be transmitted to AAC." H 1
+ .;Transmit extract summary
+ .N ANS,DUOUT,DTOUT,RTN,TEXT
+ .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
+ .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
+ .I ANS D TRANS^PXRMETX(PXRMXIEN)
+ ;
+ ;Rebuild workfile
+ D BLDLIST^PXRMETH1(IEN)
+ ;Refresh
+ S VALMBCK="R"
+ Q
+ ;
+TRHIST ;Transmission History
+ N IND,PXRMSIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .D START^PXRMETHL(PXRMSIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+VALID(FREQ,INP) ;Validate Period input
+ W !
+ N PERIOD,YEAR
+ ;Convert to upper case
+ S INP=$$UP^XLFSTR(INP)
+ ;General format
+ I $E(INP)'=FREQ D EN^DDIOL("Format should be "_FREQ_"nn/yyyy") Q 0
+ S PERIOD=$P(INP,"/"),YEAR=$P(INP,"/",2)
+ S PERIOD=$P(PERIOD,FREQ,2)
+ ;All runs
+ I (YEAR<2000)!(YEAR>2050) D EN^DDIOL("Year should be in range 2000-2050") Q 0
+ ;Quarterly run
+ I FREQ="Q",(PERIOD>4)!(PERIOD<1) D EN^DDIOL("Quarter should be in range 1-4") Q 0
+ ;Monthly run
+ I FREQ="M",(PERIOD>12)!(PERIOD<1) D EN^DDIOL("Month should be in range 1-12") Q 0
+ ;Otherwise
+ Q 1
+ ;
+VIEW ;Select view
+ ;
+ W IORESET
+ ;
+ S VALMBCK="R"
+ ;
+ N X,Y,CODE,DIR
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="S"_U_"D:Sort by Creation Date;"
+ S DIR(0)=DIR(0)_"P:Sort by Extract Period;"
+ S DIR("A")="TYPE OF VIEW"
+ S DIR("B")=$S(PXRMVIEW="P":"D",1:"P")
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ ;BOOKMARK - HELP NEEDS MOVING
+ S DIR("??")=U_"D HELP^PXRMSEL2(3)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ ;Change display type
+ S PXRMVIEW=Y
+ ;
+ ;Rebuild Workfile
+ D BLDLIST^PXRMETH1(IEN),HDR
+ Q
+ ;
+WARN(NEXT,STATUS) ;Warn if period is not completed
+ N BDATE,EDATE,FDATE
+ ;Calculate beginning and end dates for period
+ D CALC^PXRMEUT(NEXT,.BDATE,.EDATE)
+ ;No warning if period end date is a prior date
+ I $$FMDIFF^XLFDT($$NOW^XLFDT,EDATE)>0 S STATUS="COMPLETE" Q
+ ;Else Format date
+ S FDATE=$$FMTE^XLFDT(EDATE,5),STATUS="INCOMPLETE"
+ ;And Warn that period end date is a future date
+ W !!,"WARNING -This period is not complete until "_FDATE
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m

@@ -1 @@
-PXRMETH1        ; SLC/PJH - Reminder Extract History ;09/07/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-BLDLIST(EDIEN)  ;Build workfile
-        ;EDIEN is the extract definition IEN.
-        N IND,FMTSTR,PLIST
-        K ^TMP("PXRMETH",$J)
-        S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLL")
-        ;Build list of extract summaries in period order
-        I PXRMVIEW="P" D LIST1(EDIEN,"PXRMETH",FMTSTR)
-        ;Build list of extract summaries in date order
-        I PXRMVIEW="D" D LIST2(EDIEN,"PXRMETH",FMTSTR)
-        Q
-        ;
-FMT(NUMBER,NAME,EDATE,XDATE,AUTO,FMTSTR,NL,OUTPUT)      ;Format
-        N TAUTO,TDATE,TEMP,TNAME,TSOURCE
-        S TEMP=NUMBER_U_NAME_U
-        S TDATE=$$FMTE^XLFDT(EDATE,"5Z")
-        S TEMP=TEMP_$$LJ^XLFSTR(TDATE,20," ")
-        S TDATE=XDATE I TDATE S TDATE=$$FMTE^XLFDT(TDATE,"5Z")
-        S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,22," ")
-        S TAUTO=AUTO
-        S TEMP=TEMP_TAUTO
-        D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NL,.OUTPUT)
-        Q
-        ;
-HELP(CALL)      ;General help text routine.
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Select DE to delete an extract.\\"
-        .S HTEXT(2)="Select ES to view the details of an extract or run a compliance"
-        .S HTEXT(3)="report for the extract.\\Select MT to transmit extract details to the AAC.\\"
-        .S HTEXT(4)="Select TH to view the transmission history for an extract."
-        ;
-        I CALL=3 D
-        .S HTEXT(1)="Select Y to send the results of the Extract to the National Austin database."
-        ;
-        I CALL=4 D
-        .S HTEXT(4)="Select Y to overwrite the previous Extract stored in the National Austin Database."
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-LIST1(EDIEN,NODE,FMTSTR)        ;Build a list of extract summaries for a parameter.
-        N AUTO,EDATE,HL7ID,HL7SUB,IND,JND,NAME,NL,NUM,OUTPUT
-        N PERIOD,STR,XDATE,YEAR
-        ;Build list of extract summaries in reverse date order.
-        S YEAR="9999",(NUM,VALMCNT)=0
-        F  S YEAR=$O(^PXRMXT(810.3,"D",EDIEN,YEAR),-1) Q:YEAR=""  D
-        .S PERIOD="99"
-        .F  S PERIOD=$O(^PXRMXT(810.3,"D",EDIEN,YEAR,PERIOD),-1) Q:PERIOD=""  D
-        ..S IND=""
-        ..F  S IND=$O(^PXRMXT(810.3,"D",EDIEN,YEAR,PERIOD,IND),-1) Q:IND=""  D
-        ...S NAME=$P($G(^PXRMXT(810.3,IND,0)),U)
-        ...S EDATE=$P($G(^PXRMXT(810.3,IND,0)),U,6)
-        ...S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5)
-        ...S AUTO=$S(AUTO="A":"Y",1:"N")
-        ...S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB=""
-        ...I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,""))
-        ...I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
-        ...I 'XDATE S XDATE="Not Transmitted"
-        ...S NUM=NUM+1
-        ...D FMT(NUM,NAME,EDATE,XDATE,AUTO,FMTSTR,.NL,.OUTPUT)
-        ...F JND=1:1:NL D
-        ....S VALMCNT=VALMCNT+1,^TMP(NODE,$J,VALMCNT,0)=OUTPUT(JND)
-        ....S ^TMP(NODE,$J,"IDX",VALMCNT,NUM)=""
-        ....S ^TMP(NODE,$J,"SEL",NUM)=IND
-        Q
-        ;
-LIST2(EDIEN,NODE,FMTSTR)        ;Build a list of extract summaries for a parameter.
-        N AUTO,EDATE,HL7ID,HL7SUB,IND,JND,NAME,NL,NUM,OUTPUT
-        N PERIOD,STR,XDATE,YEAR
-        ;Build list of extract summaries in reverse date order.
-        S EDATE="",(NUM,VALMCNT)=0
-        F  S EDATE=$O(^PXRMXT(810.3,"C",EDIEN,EDATE),-1) Q:'EDATE  D
-        .S IND=""
-        .F  S IND=$O(^PXRMXT(810.3,"C",EDIEN,EDATE,IND)) Q:'IND  D
-        ..S NAME=$P($G(^PXRMXT(810.3,IND,0)),U,1)
-        ..S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5)
-        ..S AUTO=$S(AUTO="A":"Y",1:"N")
-        ..S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB=""
-        ..I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,""))
-        ..I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
-        ..I 'XDATE S XDATE="Not Transmitted"
-        ..S NUM=NUM+1
-        ..D FMT(NUM,NAME,EDATE,XDATE,AUTO,FMTSTR,.NL,.OUTPUT)
-        ..F JND=1:1:NL D
-        ...S VALMCNT=VALMCNT+1,^TMP(NODE,$J,VALMCNT,0)=OUTPUT(JND)
-        ...S ^TMP(NODE,$J,"IDX",VALMCNT,NUM)=""
-        ...S ^TMP(NODE,$J,"SEL",NUM)=IND
-        Q
-        ;
+PXRMETH1 ; SLC/PJH - Reminder Extract History ;07/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+BLDLIST(IEN) ;Build workfile
+ N IND,PLIST
+ K ^TMP("PXRMETH",$J)
+ ;Build list of extract summaries in period order
+ I PXRMVIEW="P" D LIST1(.PLIST,.IEN)
+ ;Build list of extract summaries in date order
+ I PXRMVIEW="D" D LIST2(.PLIST,.IEN)
+ ;Move into list array
+ M ^TMP("PXRMETH",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ ;Allow selection by item
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMETH",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
+HELP(CALL) ;General help text routine.
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Select ES to view the details of an extract or run a compliance"
+ .S HTEXT(2)="report for the extract. Select MT to transmit extract details to the AAC."
+ .S HTEXT(3)="Select TH to view the transmission history for an extract."
+ ;
+ I CALL=3 D
+ .S HTEXT(1)="Select Y to send the results of the Extract to the National Austin database."
+ ;
+ I CALL=4 D
+ .S HTEXT(4)="Select Y to overwrite the previous Extract stored in the National Austin Database."
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+LIST1(LIST,IEN) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,NAME,PERIOD,XDATE,YEAR
+ ;Build list of extract summaries in reverse date order.
+ S YEAR="9999",VALMCNT=0
+ F  S YEAR=$O(^PXRMXT(810.3,"D",IEN,YEAR),-1) Q:YEAR=""  D
+ .S PERIOD="99"
+ .F  S PERIOD=$O(^PXRMXT(810.3,"D",IEN,YEAR,PERIOD),-1) Q:PERIOD=""  D
+ ..S IND=""
+ ..F  S IND=$O(^PXRMXT(810.3,"D",IEN,YEAR,PERIOD,IND),-1) Q:IND=""  D
+ ...S NAME=$P($G(^PXRMXT(810.3,IND,0)),U)
+ ...S EDATE=$P($G(^PXRMXT(810.3,IND,0)),U,6)
+ ...S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5)
+ ...S AUTO=$S(AUTO="A":"Y",1:"N")
+ ...S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB=""
+ ...I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,""))
+ ...I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
+ ...I 'XDATE S XDATE="Not Transmitted"
+ ...S VALMCNT=VALMCNT+1
+ ...S LIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,EDATE,XDATE,AUTO)
+ ...S IEN(VALMCNT)=IND
+ S LIST("VALMCNT")=VALMCNT
+ Q
+ ;
+LIST2(LIST,IEN) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,NAME,PERIOD,XDATE,YEAR
+ ;Build list of extract summaries in reverse date order.
+ S EDATE="",VALMCNT=0
+ F  S EDATE=$O(^PXRMXT(810.3,"C",IEN,EDATE),-1) Q:'EDATE  D
+ .S IND=""
+ .F  S IND=$O(^PXRMXT(810.3,"C",IEN,EDATE,IND)) Q:'IND  D
+ ..S NAME=$P($G(^PXRMXT(810.3,IND,0)),U)
+ ..S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5)
+ ..S AUTO=$S(AUTO="A":"Y",1:"N")
+ ..S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB=""
+ ..I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,""))
+ ..I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
+ ..I 'XDATE S XDATE="Not Transmitted"
+ ..S VALMCNT=VALMCNT+1
+ ..S LIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,EDATE,XDATE,AUTO)
+ ..S IEN(VALMCNT)=IND
+ S LIST("VALMCNT")=VALMCNT
+ Q
+ ;
+FRE(NUMBER,NAME,EDATE,XDATE,AUTO) ;Format
+ N TAUTO,TDATE,TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,27)
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,27," ")
+ S TDATE=$$FMTE^XLFDT(EDATE,"5Z")
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,20," ")
+ S TDATE=XDATE I TDATE S TDATE=$$FMTE^XLFDT(TDATE,"5Z")
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,22," ")
+ S TAUTO=AUTO
+ S TEMP=TEMP_TAUTO
+ Q TEMP

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m

@@ -1 @@
-PXRMETM ; SLC/PKR/PJH - Extract/Transmission Management ;09/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM EXTRACT MANAGEMENT
-START   N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
-        S X="IORESET"
-        D ENDR^%ZISS
-        S VALMCNT=0
-        D EN^VALM("PXRM EXTRACT MANAGEMENT")
-        W IORESET
-        D KILL^%ZISS
-        Q
-        ;
-BLDLIST ;Build workfile
-        K ^TMP("PXRMETM",$J)
-        N IEN,IND,PLIST
-        D LIST("PXRMETM",.VALMCNT)
-        Q
-        ;
-ENTRY   ;Entry code
-        D BLDLIST,XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMETM",$J)
-        K ^TMP("PXRMETMH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="Q"
-        Q
-        ;
-FMT(NUMBER,NAME,CLASS)  ;Format  entry number, name
-        ;and date packed.
-        N TCLASS,TEMP,TNAME,TSOURCE
-        S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
-        S TNAME=$E(NAME,1,46)
-        S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
-        S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
-        S TEMP=TEMP_"  "_TCLASS
-        Q TEMP
-        ;
-GEN     ;Ad hoc report option
-        ;Reset Screen Mode
-        W IORESET
-        ;
-        N IND,LISTIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the ien.
-        .S LISTIEN=^TMP("PXRMETM",$J,"SEL",IND)
-        .D GENSEL(LISTIEN)
-        ;
-        S VALMBCK="R"
-        Q
-        ;
-GENSEL(IEN)     ;Report for selected extract definition
-        N ANS,BEGIN,END,RTN,TEXT
-        D DATES^PXRMEUT(.BEGIN,.END,"Report")
-        ;Options
-        S RTN="PXRMETM",TEXT="Run compliance report for this period"
-        S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:'ANS  Q:$D(DUOUT)!$D(DTOUT)
-        ;Print Report
-        D ADHOC^PXRMETCO(IEN,BEGIN,END)
-        Q
-        ;
-HDR     ; Header code
-        S VALMHDR(1)="Available Extract Definitions:"
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Select EDM to edit/display extract definitions.\\"
-        .S HTEXT(2)="Select VSE to view previous extracts or"
-        .S HTEXT(3)="initiate a manual extract or transmission."
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-HLIST   ;Extract History
-        N IND,LISTIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the ien.
-        .S LISTIEN=^TMP("PXRMETM",$J,"SEL",IND)
-        .D START^PXRMETH(LISTIEN)
-        S VALMBCK="R"
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,SUB,XQORM
-        S SUB="PXRMETMH"
-        D EN^VALM("PXRM EXTRACT HELP")
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-LIST(NODE,VALMCNT)      ;Build a list of extract definition entries.
-        N EPCLASS,IND,FNAME,NAME
-        ;Build the list in alphabetical order.
-        S VALMCNT=0
-        S NAME=""
-        F  S NAME=$O(^PXRM(810.2,"B",NAME)) Q:NAME=""  D
-        .S IND=$O(^PXRM(810.2,"B",NAME,"")) Q:'IND
-        .S FNAME=$P($G(^PXRM(810.2,IND,0)),U)
-        .S EPCLASS=$P($G(^PXRM(810.2,IND,100)),U)
-        .S VALMCNT=VALMCNT+1
-        .S ^TMP(NODE,$J,VALMCNT,0)=$$FMT(VALMCNT,FNAME,EPCLASS)
-        .S ^TMP(NODE,$J,"IDX",VALMCNT,VALMCNT)=""
-        .S ^TMP(NODE,$J,"SEL",VALMCNT)=IND
-        Q
-        ;
-PEXIT   ;Protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-PLIST   ;Extract Definition Inquiry
-        N IND,EPIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the ien.
-        .S EPIEN=^TMP("PXRMETM",$J,"SEL",IND)
-        .D START^PXRMEPED(EPIEN)
-        S VALMBCK="R"
-        Q
-        ;
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
-XSEL    ;PXRM EXTRACT MANAGEMENT SELECT ENTRY validation
-        N EDIEN,SEL
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;
-        ;Get the list ien.
-        S EDIEN=^TMP("PXRMETM",$J,"SEL",SEL)
-        ;
-        ;Full screen mode
-        D FULL^VALM1
-        ;
-        ;Options
-        N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="SBM"_U_"EDM:Extract Definition Management;"
-        S DIR(0)=DIR(0)_"VSE:Examine/Schedule Extract;"
-        S DIR("A")="Select Action"
-        S DIR("B")="VSE"
-        S DIR("?")="Select from the codes displayed. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMETM(1)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
-        S OPTION=Y
-        ;
-        ;Display Extract Definitions
-        I OPTION="EDM" D START^PXRMEPED(EDIEN)
-        ;
-        ;Examine/Run Extract
-        I OPTION="VSE" D START^PXRMETH(EDIEN)
-        ;
-        ;Examine/Run Extract
-        I OPTION="ERE" D GENSEL(EDIEN)
-        ;
-        S VALMBCK="R"
-        Q
-        ;
+PXRMETM ; SLC/PKR/PJH - Extract/Transmission Management ;05/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM EXTRACT MANAGEMENT
+START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+ S X="IORESET"
+ D ENDR^%ZISS
+ S VALMCNT=0
+ D EN^VALM("PXRM EXTRACT MANAGEMENT")
+ W IORESET
+ D KILL^%ZISS
+ Q
+ ;
+BLDLIST ;Build workfile
+ K ^TMP("PXRMETM",$J)
+ N IEN,IND,PLIST
+ D LIST(.PLIST,.IEN)
+ M ^TMP("PXRMETM",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMETM",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
+LIST(RLIST,IEN) ;Build a list of extract definition entries.
+ N EPCLASS,IND,FNAME,NAME
+ ;Build the list in alphabetical order.
+ S VALMCNT=0
+ S NAME=""
+ F  S NAME=$O(^PXRM(810.2,"B",NAME)) Q:NAME=""  D
+ .S IND=$O(^PXRM(810.2,"B",NAME,"")) Q:'IND
+ .S FNAME=$P($G(^PXRM(810.2,IND,0)),U)
+ .S EPCLASS=$P($G(^PXRM(810.2,IND,100)),U)
+ .S VALMCNT=VALMCNT+1
+ .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,FNAME,EPCLASS)
+ .S IEN(VALMCNT)=IND
+ S RLIST("VALMCNT")=VALMCNT
+ Q
+ ;
+FRE(NUMBER,NAME,CLASS) ;Format  entry number, name
+ ;and date packed.
+ N TCLASS,TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,46)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
+ S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
+ S TEMP=TEMP_"  "_TCLASS
+ Q TEMP
+ ;
+ENTRY ;Entry code
+ D BLDLIST,XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMETM",$J)
+ K ^TMP("PXRMETMH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
+HDR ; Header code
+ S VALMHDR(1)="Available Extract Definitions:"
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMETMH"
+ D EN^VALM("PXRM EXTRACT HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+PEXIT ;Protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM EXTRACT MANAGEMENT SELECT ENTRY validation
+ N SEL,IEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the list ien.
+ S IEN=^TMP("PXRMETM",$J,"IDX",SEL,SEL)
+ ;
+ ;Full screen mode
+ D FULL^VALM1
+ ;
+ ;Options
+ N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="SBM"_U_"EDM:Extract Definition Management;"
+ S DIR(0)=DIR(0)_"VSE:Examine/Schedule Extract;"
+ S DIR("A")="Select Action"
+ S DIR("B")="VSE"
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMETM(1)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
+ S OPTION=Y
+ ;
+ ;Display Extract Definitions
+ I OPTION="EDM" D
+ .D START^PXRMEPED(IEN)
+ ;
+ ;Examine/Run Extract
+ I OPTION="VSE" D
+ .D START^PXRMETH(IEN)
+ ;
+ ;Examine/Run Extract
+ I OPTION="ERE" D
+ .D GENSEL(IEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Select EDM to edit/display extract definitions."
+ .S HTEXT(2)="extract. Select VSE to view previous extracts or "
+ .S HTEXT(3)="initiate a manual extract or transmission."
+ ;
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+GEN ;Ad hoc report option
+ ;
+ ;Reset Screen Mode
+ W IORESET
+ ;
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LISTIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D GENSEL(LISTIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+GENSEL(IEN) ;Report for selected extract definition
+ N ANS,BEGIN,END,RTN,TEXT
+ D DATES^PXRMEUT(.BEGIN,.END,"Report")
+ ;Options
+ S RTN="PXRMETM",TEXT="Run compliance report for this period"
+ S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:'ANS  Q:$D(DUOUT)!$D(DTOUT)
+ ;Print Report
+ D ADHOC^PXRMETCO(IEN,BEGIN,END)
+ Q
+ ;
+HLIST ;Extract History
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LISTIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D START^PXRMETH(LISTIEN)
+ S VALMBCK="R"
+ Q
+ ;
+PLIST ;Extract Definition Inquiry
+ N IND,EPIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S EPIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D START^PXRMEPED(EPIEN)
+ ;
+ S VALMBCK="R"
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m

@@ -1 @@
-PXRMETT ; SLC/PJH - Extract Summary Display ;04/09/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM EXTRACT SUMMARY
-START(IEN)      N TOGGLE,TOGGLE1,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
-        S X="IORESET"
-        D ENDR^%ZISS
-        S VALMCNT=0,TOGGLE=0,TOGGLE1=0
-        D EN^VALM("PXRM EXTRACT SUMMARY")
-        Q
-        ;
-BLDLIST(IEN,FINDINGS,PATIENT)   ;Build workfile.
-        ;FINDINGS=1 means display finding totals
-        K ^TMP("PXRMETT",$J)
-        ;Build a list of extract summary totals.
-        N APPL,DATA,DUE,IND,LIST,NDUE,NAPPL,OLIST
-        N PLCNT,PLIST,RIEN,RNAME,SARRAY,SEQ,SNAME,STATION,TOT
-        ;Build the list in alphabetical order.
-        S VALMCNT=0,OLIST="",PLCNT=0
-        S IND=0 F  S IND=$O(^PXRMXT(810.3,IEN,3,IND)) Q:IND'>0  D
-        .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,0)) Q:DATA=""
-        .S RIEN=$P(DATA,U,2) Q:'RIEN
-        .S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
-        .I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
-        .S STATION=$P(DATA,U,3),SARRAY=""
-        .D GETS^DIQ(4,STATION,99,"E","SARRAY")
-        .S SNAME=$G(SARRAY(4,STATION_",",99,"E"))
-        .I SNAME="" S SNAME=STATION
-        .S TOT=+$P(DATA,U,5),APPL=+$P(DATA,U,6),NAPPL=+$P(DATA,U,7)
-        .S DUE=+$P(DATA,U,8),NDUE=+$P(DATA,U,9)
-        .S PLIST=$P(DATA,U,4)
-        .I PLIST,PLIST'=OLIST D
-        ..I PLCNT>0 D
-        ...S VALMCNT=VALMCNT+1
-        ...S ^TMP("PXRMETT",$J,VALMCNT,0)=""
-        ...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        ..S PLNAME=$P($G(^PXRMXP(810.5,PLIST,0)),U),OLIST=PLIST Q:PLNAME=""
-        ..S VALMCNT=VALMCNT+1,PLCNT=PLCNT+1
-        ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        ..S ^TMP("PXRMETT",$J,"SEL",PLCNT)=PLIST
-        ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR(PLCNT,4," ")_" "_PLNAME
-        .S VALMCNT=VALMCNT+1
-        .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FRE(VALMCNT,RNAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE)
-        .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        .;Finding totals
-        .I +FINDINGS>0 D FBLD(PATIENT)
-        ;
-        S ^TMP("PXRMETT",$J,"VALMCNT")=VALMCNT
-        Q
-        ;
-ENTRY   ;Entry code
-        D BLDLIST(IEN,TOGGLE,TOGGLE1),XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMETT",$J)
-        K ^TMP("PXRMETTH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="Q"
-        Q
-        ;
-FBLD(PATIENT)   ;Build finding list
-        N APPL,DATA,DUE,ETYP,EVAL,GNAM,GTYP
-        N NAPPL,NDUE,OGNAM,SEQ,SUB,TIEN,TNAME,TOTAL
-        S SUB=0,OGNAM=""
-        F  S SUB=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB)) Q:'SUB  D
-        .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,1,SUB,0)) Q:DATA=""
-        .S TIEN=$P(DATA,U,2) Q:'TIEN
-        .S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U)
-        .S SEQ=$P(DATA,U),ETYP=$P(DATA,U,3),GNAM=$P(DATA,U,9),GTYP=$P(DATA,U,10)
-        .S TOT=+$P(DATA,U,4),APPL=+$P(DATA,U,5),NAPPL=+$P(DATA,U,6)
-        .S DUE=+$P(DATA,U,7),NDUE=+$P(DATA,U,8)
-        .I OGNAM'=GNAM D
-        ..I OGNAM'="" D
-        ...S VALMCNT=VALMCNT+1
-        ...S ^TMP("PXRMETT",$J,VALMCNT,0)=""
-        ...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        ..S OGNAM=GNAM,VALMCNT=VALMCNT+1
-        ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR("Counting Group: ",21)_GNAM
-        ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="",VALMCNT=VALMCNT+1
-        ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$J("",6)_$$LJ^XLFSTR($$TXT^PXRMEPM(ETYP,GTYP),49)
-        ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        .S VALMCNT=VALMCNT+1
-        .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FREF(VALMCNT,TNAME,SEQ,TOT,APPL,NAPPL,DUE,NDUE,ETYP)
-        .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        .I +PATIENT>0 D PBLD(IEN,IND,SUB)
-        S VALMCNT=VALMCNT+1
-        S ^TMP("PXRMETT",$J,VALMCNT,0)=""
-        S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        Q
-        ;
-FLIST   ;Toggle list with/without finding totals
-        S TOGGLE=(TOGGLE+1)#2
-        I TOGGLE=0 S TOGGLE1=0
-        ;Rebuild Workfile
-        D BLDLIST(IEN,TOGGLE,TOGGLE1)
-        ;Refresh
-        S VALMBCK="R",VALMBG=1
-        Q
-        ;
-FRE(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE)  ;Format reminder entry
-        N TEMP,TNAME,TSOURCE
-        S TEMP="     "
-        S TNAME=SNAME_"/"_$E(NAME,1,35-$L(SNAME))
-        S TEMP=TEMP_$$LJ^XLFSTR(TNAME,36," ")
-        S TEMP=TEMP_$$RJ^XLFSTR(TOT,8," ")
-        S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
-        S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
-        S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
-        S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
-        Q TEMP
-        ;
-FREF(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE,ETYP)    ;Format finding entry
-        N TEMP,TNAME,TSOURCE
-        S TEMP="      "
-        S TNAME=$E(NAME,1,31)
-        S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,31," ")
-        S TEMP=TEMP_"  "_$$RJ^XLFSTR(TOT,8," ")
-        I ETYP'="FC" D
-        .S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
-        .S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
-        .S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
-        .S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
-        Q TEMP
-        ;
-HDR     ; Header code
-        S VALMHDR(1)="Extract Summary Name: "_$P($G(^PXRMXT(810.3,IEN,0)),U)
-        S VALMHDR(2)="      Extract Period: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,2),"5Z")_" - "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,3),"5Z")
-        S VALMHDR(2)=VALMHDR(2)_"   Created: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,6),"5Z")
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,XQORM
-        S SUB="PXRMETTH"
-        D EN^VALM("PXRM EXTRACT HELP")
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-PBLD(IEN,IND,SUB)       ;
-        N ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
-        S VALMCNT=VALMCNT+1,CNT=0
-        S PCNT=0 F  S PCNT=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT)) Q:PCNT'>0  D
-        .S DFN=$P($G(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U) Q:DFN'>0
-        .S NAME=$P($G(^DPT(DFN,0)),U)
-        .S CNT=CNT+1,ARRAY(NAME)=""
-        S ^TMP("PXRMETT",$J,VALMCNT,0)="     "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
-        S USTR=$P($G(^TMP("PXRMETT",$J,VALMCNT,0)),"U"),LEN=$L(USTR)
-        S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
-        .S VALMCNT=VALMCNT+1
-        .S ^TMP("PXRMETT",$J,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
-        .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        S VALMCNT=VALMCNT+1
-        S ^TMP("PXRMETT",$J,VALMCNT,0)="  "
-        S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
-        Q
-        ;
-PEXIT   ;Protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        D XQORM
-        Q
-        ;
-PLIST(IEN)      ;Patient list display
-        N IND,PLIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        ;PXRMDONE is newed in PXRMLPM
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the ien.
-        .S PLIEN=^TMP("PXRMETT",$J,"SEL",IND)
-        .D START^PXRMLPP(PLIEN)
-        S VALMBCK="R"
-        Q
-        ;
-PLIST1  ;Toggle list with/without finding totals
-        S TOGGLE1=(TOGGLE1+1)#2
-        ;Rebuild Workfile
-        D BLDLIST(IEN,TOGGLE,TOGGLE1)
-        ;Refresh
-        S VALMBCK="R",VALMBG=1
-        Q
-        ;
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
-XSEL    ;PXRM EXTRACT TOTALS SELECT ENTRY validation
-        N SEL,PLIEN
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;Get the list ien.
-        S PLIEN=^TMP("PXRMETT",$J,"SEL",SEL)
-        D START^PXRMLPP(PLIEN)
-        S VALMBCK="R"
-        Q
-        ;
+PXRMETT ; SLC/PKR/PJH - Reminder Patient List Patients ;08/08/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM PATIENT LIST
+START(IEN) N TOGGLE,TOGGLE1,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+ S X="IORESET"
+ D ENDR^%ZISS
+ S VALMCNT=0,TOGGLE=0,TOGGLE1=0
+ D EN^VALM("PXRM EXTRACT SUMMARY")
+ Q
+ ;
+BLDLIST(IEN,FINDINGS,PATIENT) ;Build workfile.
+ K ^TMP("PXRMETT",$J)
+ ;Build a list of extract summary totals.
+ N APPL,DATA,DUE,IND,LIST,NDUE,NAPPL,OLIST
+ N PLCNT,PLIST,RIEN,RNAME,SARRAY,SNAME,STATION,TOT
+ ;Build the list in alphabetical order.
+ S IND=0,VALMCNT=0,OLIST="",PLCNT=0
+ F  S IND=$O(^PXRMXT(810.3,IEN,3,IND)) Q:'IND  D
+ .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,0)) Q:DATA=""
+ .S RIEN=$P(DATA,U,2) Q:'RIEN
+ .S RNAME=$P($G(^PXD(811.9,RIEN,0)),U)
+ .S STATION=$P(DATA,U,3),SARRAY=""
+ .D GETS^DIQ(4,STATION,99,"E","SARRAY")
+ .S SNAME=$G(SARRAY(4,STATION_",",99,"E"))
+ .I SNAME="" S SNAME=STATION
+ .S TOT=+$P(DATA,U,5),APPL=+$P(DATA,U,6),NAPPL=+$P(DATA,U,7)
+ .S DUE=+$P(DATA,U,8),NDUE=+$P(DATA,U,9)
+ .S PLIST=$P(DATA,U,4)
+ .I PLIST,PLIST'=OLIST D
+ ..S PLNAME=$P($G(^PXRMXP(810.5,PLIST,0)),U),OLIST=PLIST Q:PLNAME=""
+ ..S VALMCNT=VALMCNT+1,PLCNT=PLCNT+1
+ ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ ..S ^TMP("PXRMETT",$J,"SEL",PLCNT)=PLIST
+ ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR(PLCNT,4," ")_" "_PLNAME
+ ..S VALMCNT=VALMCNT+1
+ ..S ^TMP("PXRMETT",$J,VALMCNT,0)=""
+ ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FRE(VALMCNT,RNAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE)
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=""
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ .;Finding totals
+ .I +FINDINGS>0 D FBLD(PATIENT)
+ ;
+ S ^TMP("PXRMETT",$J,"VALMCNT")=VALMCNT
+ ;M ^TMP("PXRMETT",$J)=LIST
+ Q
+ ;
+FBLD(PATIENT) ;Build finding list
+ N APPL,DATA,DUE,ETYP,EVAL,GNAM,GTYP
+ N NAPPL,NDUE,OGNAM,SEQ,SUB,TIEN,TNAME,TOTAL
+ S SUB=0,OGNAM=""
+ F  S SUB=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB)) Q:'SUB  D
+ .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,1,SUB,0)) Q:DATA=""
+ .S TIEN=$P(DATA,U,2) Q:'TIEN
+ .S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U)
+ .S SEQ=$P(DATA,U),ETYP=$P(DATA,U,3),GNAM=$P(DATA,U,9),GTYP=$P(DATA,U,10)
+ .S TOT=+$P(DATA,U,4),APPL=+$P(DATA,U,5),NAPPL=+$P(DATA,U,6)
+ .S DUE=+$P(DATA,U,7),NDUE=+$P(DATA,U,8)
+ .I OGNAM'=GNAM D
+ ..I OGNAM'="" D
+ ...S VALMCNT=VALMCNT+1
+ ...S ^TMP("PXRMETT",$J,VALMCNT,0)=""
+ ...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ ..S OGNAM=GNAM,VALMCNT=VALMCNT+1
+ ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR("Counting Group: ",21)_GNAM
+ ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="",VALMCNT=VALMCNT+1
+ ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$J("",6)_$$LJ^XLFSTR($$TXT^PXRMEPM(ETYP,GTYP),49)
+ ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FREF(VALMCNT,TNAME,SEQ,TOT,APPL,NAPPL,DUE,NDUE,ETYP)
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ .I +PATIENT>0 D PBLD(IEN,IND,SUB)
+ S VALMCNT=VALMCNT+1
+ S ^TMP("PXRMETT",$J,VALMCNT,0)=""
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ Q
+ ;
+PBLD(IEN,IND,SUB) ;
+ N ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
+ S VALMCNT=VALMCNT+1,CNT=0
+ S PCNT=0 F  S PCNT=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT)) Q:PCNT'>0  D
+ .S DFN=$P($G(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U) Q:DFN'>0
+ .S NAME=$P($G(^DPT(DFN,0)),U)
+ .S CNT=CNT+1,ARRAY(NAME)=""
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="     "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
+ S USTR=$P($G(^TMP("PXRMETT",$J,VALMCNT,0)),"U"),LEN=$L(USTR)
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S VALMCNT=VALMCNT+1
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="  "
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ Q
+ ;
+FLIST ;Toggle list with/without finding totals
+ S TOGGLE=(TOGGLE+1)#2
+ I TOGGLE=0 S TOGGLE1=0
+ ;Rebuild Workfile
+ D BLDLIST(IEN,TOGGLE,TOGGLE1)
+ ;Refresh
+ S VALMBCK="R",VALMBG=1
+ Q
+ ;
+PLIST1 ;Toggle list with/without finding totals
+ S TOGGLE1=(TOGGLE1+1)#2
+ ;Rebuild Workfile
+ D BLDLIST(IEN,TOGGLE,TOGGLE1)
+ ;Refresh
+ S VALMBCK="R",VALMBG=1
+ Q
+ ;
+FRE(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE) ;Format reminder entry
+ N TEMP,TNAME,TSOURCE
+ S TEMP="     "
+ S TNAME=SNAME_"/"_$E(NAME,1,35-$L(SNAME))
+ S TEMP=TEMP_$$LJ^XLFSTR(TNAME,36," ")
+ S TEMP=TEMP_$$RJ^XLFSTR(TOT,8," ")
+ S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
+ S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
+ S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
+ S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
+ Q TEMP
+ ;
+FREF(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE,ETYP) ;Format finding entry
+ N TEMP,TNAME,TSOURCE
+ S TEMP="      "
+ S TNAME=$E(NAME,1,31)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,31," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(TOT,8," ")
+ I ETYP'="FC" D
+ .S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ")
+ .S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ")
+ .S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ")
+ .S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ")
+ Q TEMP
+ ;
+ENTRY ;Entry code
+ D BLDLIST(IEN,TOGGLE,TOGGLE1),XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMETT",$J)
+ K ^TMP("PXRMETTH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
+HDR ; Header code
+ S VALMHDR(1)="Extract Summary Name: "_$P($G(^PXRMXT(810.3,IEN,0)),U)
+ S VALMHDR(2)="      Extract Period: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,2),"5Z")_" - "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,3),"5Z")
+ S VALMHDR(2)=VALMHDR(2)_"   Created: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,6),"5Z")
+ ;S VALMHDR(3)=VALMHDR(3)_"        Transmitted: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,4),"5Z")
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,XQORM
+ S SUB="PXRMETTH"
+ D EN^VALM("PXRM EXTRACT HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM EXTRACT TOTALS SELECT ENTRY validation
+ N SEL,PLIEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the list ien.
+ S PLIEN=^TMP("PXRMETT",$J,"SEL",SEL)
+ ;
+ D START^PXRMLPP(PLIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+PEXIT ;Protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ D XQORM
+ Q
+ ;
+PLIST(IEN) ;Patient list display
+ N IND,PLIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PLIEN=^TMP("PXRMETT",$J,"SEL",IND)
+ .D START^PXRMLPP(PLIEN)
+ ;
+ S VALMBCK="R"
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m

@@ -1 @@
-PXRMETX ; SLC/PJH - Run Extract for QUERI ;11:42 AM  17 Dec 2008
-        ;;2.0;CLINICAL REMINDERS;**4,6,7**;Feb 04, 2005;Build 1
-        ; Modified from FOIA VISTA,
-        ; Copyright (C) 2007 WorldVistA
-        ;
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ;
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ;
-        ; You should have received a copy of the GNU General Public License
-        ; along with this program; if not, write to the Free Software
-        ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
-        ;
-        ;
-AUTO(ID,PURGE)  ;Called from option scheduling (#19.2)
-        N IEN,LIST,LUVALUE,MODE,NEXT
-        S LUVALUE(1)=ID
-        D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST")
-        ;Get ien of extract parameter
-        S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN
-        ;Get next extract period
-        S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT=""
-        ;Node is Extract and Transmit
-        S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1)
-        ;Run extract
-        D RUN^PXRMETX(IEN,NEXT,MODE,PURGE)
-        ;Purge Extract Summary
-        D PRGES^PXRMETXU
-        ;Purge Patient Lists
-        D PRGPL^PXRMETXU
-        Q
-        ;
-GETNAME(NAME,CLASS)     ;Get the extract name.
-        I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME
-        N CNT,NEW
-        S (CNT,NEW)=0
-        ;If name exists concatenate count
-        F  D  Q:NEW
-        .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q
-        .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0)
-        Q NAME
-        ;
-IHD     ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI.
-        D AUTO("VA-IHD QUERI","Y")
-        Q
-        ;
-MAIL(NAME,NEXT,MODE)    ;Completion mail message
-        N FREQ,TEXT
-        S FREQ="year"
-        I $E(NEXT)="M" S FREQ="month"
-        I $E(NEXT)="Q" S FREQ="quarter"
-        ;
-        I MODE=0 S TEXT="Extract and Transmission"
-        I MODE=1 S TEXT="Extract (No Transmission)"
-        I MODE=2 S TEXT="Manual Extract and Transmission"
-        I MODE=3 S TEXT="Manual Extract (No Transmission)"
-        ;
-        S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT
-        D MES^PXRMEUT(TEXT)
-        Q
-        ;
-MH      ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI.
-        D AUTO("VA-MH QUERI","Y")
-        Q
-        ;
-        ;Begin WV change wv/so 12/17/2008
-        ;
-ACAD    ;Auto CAD entry point
-        D AUTO("VOE DOQ-IT CAD EXTRACTION")
-        Q
-        ;
-ADM     ;Auto DM entry point
-        D AUTO("VOE DOQ-IT DM EXTRACTION")
-        Q
-        ;
-AHF     ;Auto HF entry point
-        D AUTO("VOE DOQ-IT HF EXTRACTION")
-        Q
-        ;
-AHTN    ;Auto HTN entry point
-        D AUTO("VOE DOQ-IT HTN EXTRACTION")
-        Q
-        ;
-APC     ;Auto PC entry point
-        D AUTO("VOE DOQ-IT PC EXTRACTION")
-        Q
-        ;End WV change
-        ;
-RUN(IEN,NEXT,MODE,PURGE)        ;Process extract parameter
-        ; IEN is ien of Extract Parameter
-        ; NEXT is period to extract
-        ; MODE = 0 is extract and transmission
-        ; MODE = 1 is extract only
-        ; MODE = 2 is manual extract and transmission (doesn't update 810.2)
-        ; MODE = 3 is manual extract only (doesn't update 810.2)
-        ;
-        N CLASS,FDA,FDAIEN,MSG
-        N PXRMIDOD,PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
-        N ITER
-        ;Initialise
-        K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
-        ;Workfile node for ^TMP
-        S PXRMNODE="PXRMRULE"
-        ;Get details from parameter file
-        N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR
-        ;Get class from extract parameter
-        S CLASS=$P($G(^PXRM(810.2,IEN,100)),U)
-        ;Otherwise default to local
-        I $G(CLASS)="" S CLASS="L"
-        ;
-        S DATA=$G(^PXRM(810.2,IEN,0))
-        ;Determine Extract Name and period
-        S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
-        S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
-        ;Calculate report period start and end dates
-        D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
-        ;Determine output name for patient list and extract summary
-        S XNAME=NAME_" "_YEAR_" "_PERIOD
-        S NAME=$$GETNAME(XNAME)
-        S ITER=$P(NAME,"/",2)
-        ;Process (single) Denominator rule into patient list
-        N SEQ,SUB
-        S SEQ=""
-        F  S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ  D
-        .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
-        .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
-        .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
-        .S LIST=$P(DATA,U,3) Q:LIST=""
-        .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
-        .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
-        .S INDP=+$P(DATA,U,4)
-        .S INTP=+$P(DATA,U,5)
-        .;Create new patient list
-        .I ITER'="" S LIST=LIST_"/"_ITER
-        .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRUL1(LIST,CLASS) Q:'PXRMLIST
-        .;
-        .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP,ITER)
-        .;Clear ^TMP lists created for rule
-        .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
-        .;Process reminders and finding rules
-        .;If include deceased patients is true then set the flag so reminders
-        .;will be evaluated for deceased patients.
-        .S PXRMIDOD=$S(INDP:1,1:0)
-        .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
-        ;
-        ;Get the name
-        ;S NAME=$$GETNAME(XNAME)
-        ;Create extract summary entry
-        S FDA(810.3,"+1,",.01)=NAME
-        S FDA(810.3,"+1,",.02)=PXRMSTRT
-        S FDA(810.3,"+1,",.03)=PXRMSTOP
-        S FDA(810.3,"+1,",.06)=$$NOW^XLFDT
-        S FDA(810.3,"+1,",1)=IEN
-        S FDA(810.3,"+1,",2)=PARTYPE
-        S FDA(810.3,"+1,",3)=$E(PERIOD,2,99)
-        S FDA(810.3,"+1,",4)=YEAR
-        S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M")
-        S FDA(810.3,"+1,",7)=$E(PERIOD)
-        I PURGE="Y" S FDA(810.3,"+1,",50)=1
-        S FDA(810.3,"+1,",100)=CLASS
-        D UPDATE^DIE("","FDA","FDAIEN","MSG")
-        I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT
-        ;
-        ;Update extract summary from ^TMP
-        D UPDEX(FDAIEN(1))
-        ;
-        ;Transmit results
-        I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
-        ;
-        ;Update extract parameters
-        I MODE<2 D UPDPAR
-        ;
-        ;Mail message that extract completed
-        D MAIL(NAME,NEXT,MODE)
-        ;
-EXIT    ;Clear workfile
-        K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
-        Q
-        ;
-TRANS(PXRMXIEN) ;Transmit HL7 messages
-        N HL7ID,NAME,NEXT
-        S HL7ID=""
-        D HL7^PXRM7API(PXRMXIEN,1,.HL7ID)
-        H 2
-        ;Lock extract summary
-        D LOCK(PXRMXIEN) Q:$D(DUOUT)
-        ;Update run information
-        S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U)
-        S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3)
-        S FDA(810.3,"?1,",.01)=NAME
-        S FDA(810.36,"?+2,?1,",.01)=HL7ID
-        S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT
-        D UPDATE^DIE("","FDA","","MSG")
-        ;Unlock extract summary
-        D UNLOCK(PXRMXIEN)
-        Q
-        ;
-UPDEX(IEN)      ;Update extract summary
-        N DUOUT
-        ;Lock extract summary
-        D LOCK(IEN) Q:$D(DUOUT)
-        ;
-        ;Update totals section
-        N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL
-        N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ
-        N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP
-        S SEQ="",CNT=1,RSEQ=0
-        F  S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ=""  D
-        .S INST=0
-        .F  S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST  D
-        ..S RCNT=""
-        ..F  S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT=""  D
-        ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA
-        ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3)
-        ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6)
-        ...S PXRMLIST=$P(DATA,U,7)
-        ...S CNT=CNT+1,RSEQ=RSEQ+1
-        ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE
-        ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP
-        ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)=""
-        ...;For each count type
-        ...S GSEQ="",FCNT=0
-        ...F  S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ=""  D
-        ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ))
-        ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3)
-        ....;For each term
-        ....S FSEQ=0
-        ....F  S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ=""  D
-        .....;Get the term ien
-        .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1
-        .....;Update finding totals
-        .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
-        .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4)
-        .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6)
-        .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA
-        .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP
-        .....;
-        .....;AGP REMOVE UNTIL A DECISION CAN BE MADE
-        .....;S DFN=0,PCNT=0
-        .....;F  S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0  D
-        .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN
-        .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT
-        ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT
-        .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ
-        ;Unlock extract summary
-        D UNLOCK(IEN)
-        Q
-        ;
-        ;File locking
-LOCK(PXRMXIEN)  L +^PXRMXT(810.3,PXRMXIEN):0
-        I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1
-        Q
-        ;
-UNLOCK(PXRMXIEN)        L -^PXRMXT(810.3,PXRMXIEN) Q
-        ;
-UPDPAR  ;Update parameters when run complete
-        N DATA,LAST,NEXT,PERIOD,TYPE,YEAR
-        S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3)
-        ;Last run updated
-        S LAST=NEXT
-        ;Calculate next run
-        I TYPE="Y" S NEXT=NEXT+1
-        I "QM"[TYPE D
-        .N NUM
-        .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2)
-        .S NUM=$P(PERIOD,TYPE,2)+1
-        .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1
-        .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1
-        .S NEXT=TYPE_NUM_"/"_YEAR
-        ;Update last and next run fields
-        S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT
-        Q
-        ;
+PXRMETX ; SLC/PJH - Run Extract for QUERI ;1/22/07  21:25
+ ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+AUTO(ID,PURGE) ;Called from option scheduling (#19.2)
+ N IEN,LIST,LUVALUE,MODE,NEXT
+ S LUVALUE(1)=ID
+ D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST")
+ ;Get ien of extract parameter
+ S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN
+ ;Get next extract period
+ S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT=""
+ ;Node is Extract and Transmit
+ S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1)
+ ;Run extract
+ D RUN^PXRMETX(IEN,NEXT,MODE,PURGE)
+ ;Purge Extract Summary
+ D PRGES^PXRMETXU
+ ;Purge Patient Lists
+ D PRGPL^PXRMETXU
+ ;Call the DOQ-IT HL7 generating routine
+ ;D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"))
+ Q
+ ;
+GETNAME(NAME,CLASS) ;Get the extract name.
+ I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME
+ N CNT,NEW
+ S (CNT,NEW)=0
+ ;If name exists concatenate count
+ F  D  Q:NEW
+ .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q
+ .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0)
+ Q NAME
+ ;
+IHD ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI.
+ D AUTO("VA-IHD QUERI","Y")
+ Q
+ ;
+MAIL(NAME,NEXT,MODE) ;Completion mail message
+ N FREQ,TEXT
+ S FREQ="year"
+ I $E(NEXT)="M" S FREQ="month"
+ I $E(NEXT)="Q" S FREQ="quarter"
+ ;
+ I MODE=0 S TEXT="Extract and Transmission"
+ I MODE=1 S TEXT="Extract (No Transmission)"
+ I MODE=2 S TEXT="Manual Extract and Transmission"
+ I MODE=3 S TEXT="Manual Extract (No Transmission)"
+ ;
+ S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT
+ D MES^PXRMEUT(TEXT)
+ Q
+ ;
+MH ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI.
+ D AUTO("VA-MH QUERI","Y")
+ Q
+ ;
+ACAD ;Auto CAD entry point
+ D AUTO("VOE DOQ-IT CAD EXTRACTION")
+ Q
+ ;
+ADM ;Auto DM entry point
+ D AUTO("VOE DOQ-IT DM EXTRACTION")
+ Q
+ ;
+AHF ;Auto HF entry point
+ D AUTO("VOE DOQ-IT HF EXTRACTION")
+ Q
+ ;
+AHTN ;Auto HTN entry point
+ D AUTO("VOE DOQ-IT HTN EXTRACTION")
+ Q
+ ;
+APC ;Auto PC entry point
+ D AUTO("VOE DOQ-IT PC EXTRACTION")
+ Q
+ ;
+RUN(IEN,NEXT,MODE,PURGE) ;Process extract parameter
+ ; IEN is ien of Extract Parameter
+ ; NEXT is period to extract
+ ; MODE = 0 is extract and transmission
+ ; MODE = 1 is extract only
+ ; MODE = 2 is manual extract and transmission (doesn't update 810.2)
+ ; MODE = 3 is manual extract only (doesn't update 810.2)
+ ;
+ N CLASS,FDA,FDAIEN,MSG
+ N PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
+ ;Initialise
+ K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
+ ;Workfile node for ^TMP
+ S PXRMNODE="PXRMRULE"
+ ;Get details from parameter file
+ N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR
+ ;Get class from extract parameter
+ S CLASS=$P($G(^PXRM(810.2,IEN,100)),U)
+ ;Otherwise default to local
+ I $G(CLASS)="" S CLASS="L"
+ ;
+ S DATA=$G(^PXRM(810.2,IEN,0))
+ ;Determine Extract Name and period
+ S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2)
+ S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/")
+ ;Calculate report period start and end dates
+ D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP)
+ ;Determine output name for patient list and extract summary
+ S XNAME=NAME_" "_YEAR_" "_PERIOD
+ ;Process (single) Denominator rule into patient list
+ N SEQ,SUB
+ S SEQ=""
+ F  S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ  D
+ .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
+ .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA=""
+ .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
+ .S LIST=$P(DATA,U,3) Q:LIST=""
+ .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
+ .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
+ .S INDP=+$P(DATA,U,4)
+ .S INTP=+$P(DATA,U,5)
+ .;Create new patient list
+ .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRULE(LIST,CLASS) Q:'PXRMLIST
+ .;
+ .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP)
+ .;Clear ^TMP lists created for rule
+ .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
+ .;Process reminders and finding rules
+ .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
+ ;
+ ;Get the name
+ S NAME=$$GETNAME(XNAME)
+ ;Create extract summary entry
+ S FDA(810.3,"+1,",.01)=NAME
+ S FDA(810.3,"+1,",.02)=PXRMSTRT
+ S FDA(810.3,"+1,",.03)=PXRMSTOP
+ S FDA(810.3,"+1,",.06)=$$NOW^XLFDT
+ S FDA(810.3,"+1,",1)=IEN
+ S FDA(810.3,"+1,",2)=PARTYPE
+ S FDA(810.3,"+1,",3)=$E(PERIOD,2,99)
+ S FDA(810.3,"+1,",4)=YEAR
+ S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M")
+ S FDA(810.3,"+1,",7)=$E(PERIOD)
+ I PURGE="Y" S FDA(810.3,"+1,",50)=1
+ S FDA(810.3,"+1,",100)=CLASS
+ D UPDATE^DIE("","FDA","FDAIEN","MSG")
+ I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT
+ ;
+ ;Update extract summary from ^TMP
+ D UPDEX(FDAIEN(1))
+ ;
+ ;Transmit results
+ I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
+ ;
+ I $$GET^XPAR("SYS","DOQ-IT")="YES" D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"),PXRMLIST)
+ ;
+ ;Update extract parameters
+ I MODE<2 D UPDPAR
+ ;
+ ;Mail message that extract completed
+ D MAIL(NAME,NEXT,MODE)
+ ;
+EXIT ;Clear workfile
+ K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
+ Q
+ ;
+TRANS(PXRMXIEN) ;Transmit HL7 messages
+ N HL7ID,NAME,NEXT
+ S HL7ID=""
+ D HL7^PXRM7API(PXRMXIEN,1,.HL7ID)
+ H 2
+ ;Lock extract summary
+ D LOCK(PXRMXIEN) Q:$D(DUOUT)
+ ;Update run information
+ S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U)
+ S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3)
+ S FDA(810.3,"?1,",.01)=NAME
+ S FDA(810.36,"?+2,?1,",.01)=HL7ID
+ S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT
+ D UPDATE^DIE("","FDA","","MSG")
+ ;Unlock extract summary
+ D UNLOCK(PXRMXIEN)
+ Q
+ ;
+UPDEX(IEN) ;Update extract summary
+ N DUOUT
+ ;Lock extract summary
+ D LOCK(IEN) Q:$D(DUOUT)
+ ;
+ ;Update totals section
+ N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL
+ N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ
+ N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP
+ S SEQ="",CNT=1,RSEQ=0
+ F  S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ=""  D
+ .S INST=0
+ .F  S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST  D
+ ..S RCNT=""
+ ..F  S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT=""  D
+ ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA
+ ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3)
+ ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6)
+ ...S PXRMLIST=$P(DATA,U,7)
+ ...S CNT=CNT+1,RSEQ=RSEQ+1
+ ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE
+ ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP
+ ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)=""
+ ...;For each count type
+ ...S GSEQ="",FCNT=0
+ ...F  S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ=""  D
+ ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ))
+ ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3)
+ ....;For each term
+ ....S FSEQ=0
+ ....F  S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ=""  D
+ .....;Get the term ien
+ .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1
+ .....;Update finding totals
+ .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
+ .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4)
+ .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6)
+ .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA
+ .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP
+ .....;
+ .....;AGP REMOVE UNTIL A DECISION CAN BE MADE
+ .....;S DFN=0,PCNT=0
+ .....;F  S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0  D
+ .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN
+ .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT
+ ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT
+ .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ
+ ;Unlock extract summary
+ D UNLOCK(IEN)
+ Q
+ ;
+ ;File locking
+LOCK(PXRMXIEN) L +^PXRMXT(810.3,PXRMXIEN):0
+ I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1
+ Q
+ ;
+UNLOCK(PXRMXIEN) L -^PXRMXT(810.3,PXRMXIEN) Q
+ ;
+UPDPAR ;Update parameters when run complete
+ N DATA,LAST,NEXT,PERIOD,TYPE,YEAR
+ S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3)
+ ;Last run updated
+ S LAST=NEXT
+ ;Calculate next run
+ I TYPE="Y" S NEXT=NEXT+1
+ I "QM"[TYPE D
+ .N NUM
+ .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2)
+ .S NUM=$P(PERIOD,TYPE,2)+1
+ .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1
+ .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1
+ .S NEXT=TYPE_NUM_"/"_YEAR
+ ;Update last and next run fields
+ S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m

@@ -1 @@
-PXRMETXR        ; SLC/PJH,PKR - Reminder section of extract ;02/22/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRMETX
-        ;
-DATE    ;Check if finding is most recent in evaluation group
-        N FDATE,GDATE
-        ;Determine finding date and existing group date
-        S FDATE=$G(FIEV(FNUM,"DATE")),GDATE=$G(GROUP(GSEQ,"DATE")) Q:FDATE=""
-        ;Ignore findings outside to the extract period
-        ;I $$FMDIFF^XLFDT(PXRMSTRT,FDATE,2)>0 Q
-        ;If this is first or only entry in group then save finding date
-        I 'GDATE S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q
-        ;Save finding if most recent date for the group
-        I $$FMDIFF^XLFDT(FDATE,GDATE,2)>0 S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q
-        Q
-        ;
-FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP)        ;Process findings for reminder
-        ;Default is extract no findings
-        N DATA,FCNT,FIEN,FIND,FNUM,FSEQ,GDATA,GROUP,GSEQ,GTYP
-        S FNUM=0,FCNT=0
-        F  S FNUM=$O(FIEV(FNUM)) Q:'FNUM  D
-        .;Ignore if not found for patient
-        .I +FIEV(FNUM)=0 Q
-        .;Only terms are counted
-        .S FIND=$G(FIEV(FNUM,"TERM IEN")) Q:FIND=""
-        .;Check if in list to be accumulated
-        .I '$D(REM(RCNT,FIND)) Q
-        .;Find groups to which finding belongs
-        .S GSEQ=""
-        .F  S GSEQ=$O(REM(RCNT,FIND,GSEQ)) Q:GSEQ=""  D
-        ..;Determine Evaluation type
-        ..S GTYP=REM(RCNT,FIND,GSEQ)
-        ..;Ignore utilization groups
-        ..I GTYP="UR" Q
-        ..;Sequence determines where the finding will be stored
-        ..S FSEQ=""
-        ..F  S FSEQ=$O(REM(RCNT,FIND,GSEQ,FSEQ)) Q:FSEQ=""  D
-        ...;Evaluation Group logic to save latest entry only
-        ...I GTYP="MRFP" D DATE Q
-        ...;Save finding totals
-        ...D UPD(1)
-        ;
-        ;Check for group totals
-        S GSEQ=""
-        F  S GSEQ=$O(GROUP(GSEQ)) Q:GSEQ=""  D
-        .S GDATA=$G(GROUP(GSEQ)) Q:GDATA=""
-        .;Update if found
-        .S FSEQ=$P(GDATA,U) D UPD(1)
-        ;
-        ;Utilization counts are done separately
-        N CNT,FDATA,FIND,FINDPA,FTIEN,GTYP,TERMARR,TFIEVAL
-        ;modify start date to include incomplete dates
-        I $E(PXRMSTRT,6,7)="01" S PXRMSTRT=$E(PXRMSTRT,1,5)_"00"
-        ;Include incomplete dates in January
-        I $E(PXRMSTRT,4,5)="01" S PXRMSTRT=$E(PXRMSTRT,1,3)_"0000"
-        ;Set start and stop dates for term
-        ;S $P(FINDPA(0),U,8)=PXRMSTRT,$P(FINDPA(0),U,11)=PXRMSTOP
-        S $P(FINDPA(0),U,11)=PXRMSTOP
-        ;Count all entries
-        S $P(FINDPA(0),U,14)="*"
-        ;
-        S FTIEN="",GTYP="UR"
-        F  S FTIEN=$O(FUTIL(RCNT,FTIEN)) Q:FTIEN=""  D
-        .S GSEQ=""
-        .F  S GSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ)) Q:GSEQ=""  D
-        ..S FSEQ=""
-        ..F  S FSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ,FSEQ)) Q:FSEQ=""  D
-        ...;Recover list of term findings
-        ...K TERMARR M TERMARR=FUTIL(RCNT,FTIEN,GSEQ,FSEQ)
-        ...;Process term 
-        ...K TFIEVAL D EVALTERM^PXRMTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
-        ...D URCNT(PXRMSTRT,PXRMSTOP,.TFIEVAL)
-        ;Determine count from PLIST then add to ETX
-        ;S CNT=+$O(PLIST(1,999999),-1) Q:'CNT
-        ;D UPD(CNT)
-        Q
-        ;
-FRULE(FRIEN,RCNT,SEQ,REM,FUTIL) ;Build array of findings in the finding rule
-        N DATA,FIND,FSEQ,GIEN,GNAM,GSEQ,GTYP,GSTA,SUB,TLIST
-        S GSEQ=0
-        F  S GSEQ=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ)) Q:GSEQ=""  D
-        .S SUB=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ,"")) Q:'SUB
-        .S DATA=$G(^PXRM(810.7,FRIEN,10,SUB,0)) Q:DATA=""
-        .;Get the finding group ien and reminder status
-        .S GIEN=$P(DATA,U,2),GSTA=$P(DATA,U,3) Q:'GIEN
-        .;If no status then report finding totals for all patients 
-        .I GSTA="" S GSTA="T"
-        .;Get finding group info
-        .S DATA=$G(^PXRM(810.8,GIEN,0)) Q:DATA=""
-        .;Get group name and count type
-        .S GTYP=$P(DATA,U,3),GNAM=$P(DATA,U) Q:GTYP=""
-        .;Save group in workfile
-        .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP_U_GSTA
-        .;Get all findings in group
-        .S FSEQ=0
-        .F  S FSEQ=$O(^PXRM(810.8,GIEN,10,"B",FSEQ)) Q:FSEQ=""  D
-        ..S SUB=$O(^PXRM(810.8,GIEN,10,"B",FSEQ,"")) Q:'SUB
-        ..S DATA=$G(^PXRM(810.8,GIEN,10,SUB,0)) Q:DATA=""
-        ..;Get the finding ien and exclusion status
-        ..S FIND=$P(DATA,U,2) Q:'FIND
-        ..;Initialize count for finding
-        ..S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND
-        ..;Reminder evaluation counts work from REM
-        ..I GTYP'="UR" D  Q
-        ...S REM(RCNT,FIND,GSEQ,FSEQ)=""
-        ...S REM(RCNT,FIND,GSEQ)=GTYP
-        ..;Utilization counts work from FUTIL
-        ..D TERM^PXRMLDR(FIND,.TLIST)
-        ..;Save TLIST
-        ..M FUTIL(RCNT,FIND,GSEQ,FSEQ)=TLIST
-        Q
-        ;
-REM(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)     ;Run reminders against patient
-        ;lists.
-        N APPL,DATA,DEFARR,DEFSITE,DFN,DUE,FIEV,FRIEN,FUTIL,IND,INST
-        N PXRMDATE,RCNT,REM,REMSEQ,RIEN,RNAM,STATUS,SUB1,TODAY
-        N END,START
-        ;S START=$H
-        S TODAY=$$DT^XLFDT
-        ;Evaluation date is period end except if the period is incomplete
-        S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
-        ;Scan reminders for this parameter set
-        S (RCNT,SUB1)=0
-        S REMSEQ=""
-        F  S REMSEQ=$O(^PXRM(810.2,IEN,10,SUB,10,"B",REMSEQ)) Q:REMSEQ=""  D
-        .F  S SUB1=$O(^PXRM(810.2,IEN,10,SUB,10,"B",REMSEQ,SUB1)) Q:'SUB1  D
-        ..S DATA=$G(^PXRM(810.2,IEN,10,SUB,10,SUB1,0)) Q:DATA=""
-        ..;Reminder ien
-        ..S RIEN=$P(DATA,U,2) Q:'RIEN
-        ..;Evaluation date is period end except if the period is incomplete.
-        ..S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
-        ..;Finding Rule
-        ..S FRIEN=$P(DATA,U,3)
-        ..;Reminder print name
-        ..S RNAM=$P($G(^PXD(811.9,RIEN,0)),U,3)
-        ..I RNAM="" S RNAM=$P(^PXD(811.9,RIEN,0),U,1)
-        ..;Save details to REM array
-        ..S RCNT=RCNT+1,REM(RCNT)=RIEN_U_RNAM_U_FRIEN
-        ..;Build list of terms from extract finding rule #810.7
-        ..I FRIEN D FRULE(FRIEN,RCNT,SEQ,.REM,.FUTIL) Q
-        ..;If no extract finding rule defined collect all findings in reminder
-        ..I 'FRIEN D REMF(RIEN,RCNT,SEQ,.REM)
-        ;
-        ;Process patient list
-        S IND=0,DEFSITE=+$P($$SITE^VASITE,U,3)
-        F  S IND=$O(^PXRMXP(810.5,PXRMLIST,30,IND)) Q:'IND  D
-        .S DFN=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U) Q:'DFN
-        .S INST=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U,2)
-        .I INST="" S INST=DEFSITE
-        .S RCNT=0
-        .F  S RCNT=$O(REM(RCNT)) Q:'RCNT  D
-        ..S RIEN=$P(REM(RCNT),U),RNAM=$P(REM(RCNT),U,2),FRIEN=$P(REM(RCNT),U,3)
-        ..;Clear evaluation arrays.
-        ..K ^TMP("PXRHM",$J),^TMP("PXRMID",$J),FIEV
-        ..;Evaluate reminders and store results
-        ..D DEF^PXRMLDR(RIEN,.DEFARR)
-        ..D EVAL^PXRM(DFN,.DEFARR,1,1,.FIEV,PXRMDATE)
-        ..;Determine update from reminder status
-        ..S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAM)),U) I STATUS="" Q
-        ..;Ignore not applicables
-        ..S APPL=$S(STATUS["DUE":1,STATUS="RESOLVED":1,STATUS="DONE":1,1:0)
-        ..;Check if due
-        ..S DUE=$S(STATUS="DUE NOW":1,1:0)
-        ..;Compliance totals
-        ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT))
-        ..;Reminder ien
-        ..I $P(DATA,U)="" S $P(DATA,U)=RIEN
-        ..;Evaluated total
-        ..S $P(DATA,U,2)=$P(DATA,U,2)+1
-        ..;Applicable total
-        ..S $P(DATA,U,3)=$P(DATA,U,3)+APPL
-        ..;Not applicable total
-        ..I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+1
-        ..;Due total
-        ..S $P(DATA,U,5)=$P(DATA,U,5)+DUE
-        ..;Not due count
-        ..I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+1
-        ..;Add patient list
-        ..I $P(DATA,U,7)="" S $P(DATA,U,7)=PXRMLIST
-        ..;Update workfile
-        ..S ^TMP("PXRMETX",$J,SEQ,INST,RCNT)=DATA
-        ..;Save finding totals
-        ..I PARTYPE="CF" D FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP)
-        ;Clear evaluation fields
-        K ^TMP("PXRHM",$J),^TMP("PXRMID",$J)
-        ;S END=$H
-        ;W !,"REMINDER EVALUATION TIME"
-        ;D DETIME^PXRMXSEL(START,END)
-        Q
-        ;
-REMF(RIEN,RCNT,SEQ,REM) ;Build array of all findings in the reminder
-        N GNAM,GSEQ,FIND,FSEQ,GTYP,SUB
-        S GNAM="Finding totals",GSEQ="001",FSEQ=0,GTYP="MRF"
-        ;Save group name
-        S ^TMP("PXRMETX",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP
-        ;Select all findings in the reminder
-        S SUB=0
-        F  S SUB=$O(^PXD(811.9,RIEN,20,SUB)) Q:'SUB  D
-        .;Ignore if finding is not a term
-        .S FIND=$P($G(^PXD(811.9,RIEN,20,SUB,0)),U) Q:FIND'["PXRMD(811.5"
-        .;Convert to term ien
-        .S FIND=$P(FIND,";")
-        .;Build sequence number
-        .S FSEQ=FSEQ+1,FSEQ=$$RJ^XLFSTR(FSEQ,3,0)
-        .;Evaluation counts
-        .S REM(RCNT,FIND,GSEQ,FSEQ)=""
-        .S REM(RCNT,FIND,GSEQ)=GTYP
-        .;Update Workfile
-        .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND
-        Q
-        ;
-URCNT(PXRMSTRT,PXRMSTOP,TFIEVAL)        ;
-        ;Handle counting all valid occurrences for the finding items.
-        ;Includes historical entries that were entered within the reporting
-        ;period, cut the encounter date if it is outside the reporting period.
-        N CNT,DATEENT,FDATE,FILE,FNUM,FOCCNUM,HIST,NODE,SCAT,VIEN
-        S CNT=0,FNUM=0
-        F  S FNUM=$O(TFIEVAL(FNUM)) Q:FNUM'>0  D
-        .S FILE=$G(TFIEVAL(FNUM,"FILE NUMBER"))
-        .S HIST=$S(FILE=9000010.18:1,FILE=9000010.13:1,FILE=9000010.23:1,FILE=9000010.16:1,FILE=9000010.07:1,FILE=9000010.12:1,FILE=9000010.15:1,1:0)
-        .S FOCCNUM=0 F  S FOCCNUM=$O(TFIEVAL(FNUM,FOCCNUM)) Q:FOCCNUM'>0  D
-        ..S FDATE=$P(TFIEVAL(FNUM,FOCCNUM,"DATE"),".") Q:FDATE'>0
-        ..I HIST=0,FDATE=PXRMSTRT!(FDATE>PXRMSTRT) S CNT=CNT+1
-        ..I HIST=1 D
-        ...S VIEN=TFIEVAL(FNUM,FOCCNUM,"VISIT") Q:VIEN'>0
-        ...S NODE=$G(^AUPNVSIT(VIEN,0))
-        ...S SCAT=$P(NODE,U,7),DATEENT=$P($P(NODE,U,2),".")
-        ...I FDATE=PXRMSTRT!(FDATE>PXRMSTRT),SCAT'="E" S CNT=CNT+1 Q
-        ...I SCAT="E",(DATEENT=PXRMSTRT!(DATEENT>PXRMSTRT))&(DATEENT=PXRMSTOP!(DATEENT<PXRMSTOP)) S CNT=CNT+1
-        D UPD(CNT)
-        Q
-        ;
-UPD(CNT)        ;Update totals
-        S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
-        ;Total count
-        S $P(DATA,U,2)=$P(DATA,U,2)+CNT
-        ;Applicable count
-        S $P(DATA,U,3)=$P(DATA,U,3)+(APPL*CNT)
-        ;Not applicable count
-        I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+CNT
-        ;Due count
-        S $P(DATA,U,5)=$P(DATA,U,5)+(DUE*CNT)
-        ;Not due count
-        I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+CNT
-        ;Update current count
-        S ^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ)=DATA
-        ;AGP REMOVE UNTIL A DECISION CAN BE MADE
-        ;I CNT=1,APPL=1 S ^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)=DFN
-        Q
-        ;
+PXRMETXR ; SLC/PJH,PKR - Reminder section of extract ;05/01/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ; Called from PXRMETX
+ ;
+DATE ;Check if finding is most recent in evaluation group
+ N FDATE,GDATE
+ ;Determine finding date and existing group date
+ S FDATE=$G(FIEV(FNUM,"DATE")),GDATE=$G(GROUP(GSEQ,"DATE")) Q:FDATE=""
+ ;Ignore findings outside to the extract period
+ ;I $$FMDIFF^XLFDT(PXRMSTRT,FDATE,2)>0 Q
+ ;If this is first or only entry in group then save finding date
+ I 'GDATE S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q
+ ;Save finding if most recent date for the group
+ I $$FMDIFF^XLFDT(FDATE,GDATE,2)>0 S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q
+ Q
+ ;
+FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP) ;Process findings for reminder
+ ;Default is extract no findings
+ N DATA,FCNT,FIEN,FIND,FNUM,FSEQ,GDATA,GROUP,GSEQ,GTYP
+ S FNUM=0,FCNT=0
+ F  S FNUM=$O(FIEV(FNUM)) Q:'FNUM  D
+ .;Ignore if not found for patient
+ .I +FIEV(FNUM)=0 Q
+ .;Only terms are counted
+ .S FIND=$G(FIEV(FNUM,"TERM IEN")) Q:FIND=""
+ .;Check if in list to be accumulated
+ .I '$D(REM(RCNT,FIND)) Q
+ .;Find groups to which finding belongs
+ .S GSEQ=""
+ .F  S GSEQ=$O(REM(RCNT,FIND,GSEQ)) Q:GSEQ=""  D
+ ..;Determine Evaluation type
+ ..S GTYP=REM(RCNT,FIND,GSEQ)
+ ..;Ignore utilization groups
+ ..I GTYP="UR" Q
+ ..;Sequence determines where the finding will be stored
+ ..S FSEQ=""
+ ..F  S FSEQ=$O(REM(RCNT,FIND,GSEQ,FSEQ)) Q:FSEQ=""  D
+ ...;Evaluation Group logic to save latest entry only
+ ...I GTYP="MRFP" D DATE Q
+ ...;Save finding totals
+ ...D UPD(1)
+ ;
+ ;Check for group totals
+ S GSEQ=""
+ F  S GSEQ=$O(GROUP(GSEQ)) Q:GSEQ=""  D
+ .S GDATA=$G(GROUP(GSEQ)) Q:GDATA=""
+ .;Update if found
+ .S FSEQ=$P(GDATA,U) D UPD(1)
+ ;
+ ;Utilization counts are done separately
+ N CNT,FDATA,FIND,FINDPA,FTIEN,GTYP,TERMARR,TFIEVAL
+ ;modify start date to include incomplete dates
+ I $E(PXRMSTRT,6,7)="01" S PXRMSTRT=$E(PXRMSTRT,1,5)_"00"
+ ;Include incomplete dates in January
+ I $E(PXRMSTRT,4,5)="01" S PXRMSTRT=$E(PXRMSTRT,1,3)_"0000"
+ ;Set start and stop dates for term
+ ;S $P(FINDPA(0),U,8)=PXRMSTRT,$P(FINDPA(0),U,11)=PXRMSTOP
+ S $P(FINDPA(0),U,11)=PXRMSTOP
+ ;Count all entries
+ S $P(FINDPA(0),U,14)="*"
+ ;
+ S FTIEN="",GTYP="UR"
+ F  S FTIEN=$O(FUTIL(RCNT,FTIEN)) Q:FTIEN=""  D
+ .S GSEQ=""
+ .F  S GSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ)) Q:GSEQ=""  D
+ ..S FSEQ=""
+ ..F  S FSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ,FSEQ)) Q:FSEQ=""  D
+ ...;Recover list of term findings
+ ...K TERMARR M TERMARR=FUTIL(RCNT,FTIEN,GSEQ,FSEQ)
+ ...;Process term 
+ ...K TFIEVAL D EVALTERM^PXRMTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
+ ...D URCNT(PXRMSTRT,PXRMSTOP,.TFIEVAL)
+ ;Determine count from PLIST then add to ETX
+ ;S CNT=+$O(PLIST(1,999999),-1) Q:'CNT
+ ;D UPD(CNT)
+ Q
+ ;
+FRULE(FRIEN,RCNT,SEQ,REM,FUTIL) ;Build array of findings in the finding rule
+ N DATA,FIND,FSEQ,GIEN,GNAM,GSEQ,GTYP,GSTA,SUB,TLIST
+ S GSEQ=0
+ F  S GSEQ=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ)) Q:GSEQ=""  D
+ .S SUB=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ,"")) Q:'SUB
+ .S DATA=$G(^PXRM(810.7,FRIEN,10,SUB,0)) Q:DATA=""
+ .;Get the finding group ien and reminder status
+ .S GIEN=$P(DATA,U,2),GSTA=$P(DATA,U,3) Q:'GIEN
+ .;If no status then report finding totals for all patients 
+ .I GSTA="" S GSTA="T"
+ .;Get finding group info
+ .S DATA=$G(^PXRM(810.8,GIEN,0)) Q:DATA=""
+ .;Get group name and count type
+ .S GTYP=$P(DATA,U,3),GNAM=$P(DATA,U) Q:GTYP=""
+ .;Save group in workfile
+ .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP_U_GSTA
+ .;Get all findings in group
+ .S FSEQ=0
+ .F  S FSEQ=$O(^PXRM(810.8,GIEN,10,"B",FSEQ)) Q:FSEQ=""  D
+ ..S SUB=$O(^PXRM(810.8,GIEN,10,"B",FSEQ,"")) Q:'SUB
+ ..S DATA=$G(^PXRM(810.8,GIEN,10,SUB,0)) Q:DATA=""
+ ..;Get the finding ien and exclusion status
+ ..S FIND=$P(DATA,U,2) Q:'FIND
+ ..;Initialize count for finding
+ ..S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND
+ ..;Reminder evaluation counts work from REM
+ ..I GTYP'="UR" D  Q
+ ...S REM(RCNT,FIND,GSEQ,FSEQ)=""
+ ...S REM(RCNT,FIND,GSEQ)=GTYP
+ ..;Utilization counts work from FUTIL
+ ..D TERM^PXRMLDR(FIND,.TLIST)
+ ..;Save TLIST
+ ..M FUTIL(RCNT,FIND,GSEQ,FSEQ)=TLIST
+ Q
+ ;
+REM(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE) ;Run reminders against patient
+ ;lists.
+ N APPL,DATA,DEFARR,DEFSITE,DFN,DUE,FIEV,FRIEN,FUTIL,IND,INST
+ N PXRMDATE,RCNT,REM,RIEN,RNAM,STATUS,SUB1,TODAY
+ N END,START
+ ;S START=$H
+ S TODAY=$$DT^XLFDT
+ ;Evaluation date is period end except if the period is incomplete
+ S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
+ ;Scan reminders for this parameter set
+ S (RCNT,SUB1)=0
+ F  S SUB1=$O(^PXRM(810.2,IEN,10,SUB,10,SUB1)) Q:'SUB1  D
+ .S DATA=$G(^PXRM(810.2,IEN,10,SUB,10,SUB1,0)) Q:DATA=""
+ .;Reminder ien
+ .S RIEN=$P(DATA,U,2) Q:'RIEN
+ .;Evaluation date is period end except if the period is incomplete.
+ .S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
+ .;Finding Rule
+ .S FRIEN=$P(DATA,U,3)
+ .;Reminder print name
+ .S RNAM=$P($G(^PXD(811.9,RIEN,0)),U,3)
+ .;Save details to REM array
+ .S RCNT=RCNT+1,REM(RCNT)=RIEN_U_RNAM_U_FRIEN
+ .;Build list of terms from extract finding rule #810.7
+ .I FRIEN D FRULE(FRIEN,RCNT,SEQ,.REM,.FUTIL) Q
+ .;If no extract finding rule defined collect all findings in reminder
+ .I 'FRIEN D REMF(RIEN,RCNT,SEQ,.REM)
+ ;
+ ;Process patient list
+ S IND=0,DEFSITE=+$P($$SITE^VASITE,U,3)
+ F  S IND=$O(^PXRMXP(810.5,PXRMLIST,30,IND)) Q:'IND  D
+ .S DFN=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U) Q:'DFN
+ .S INST=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U,2)
+ .I INST="" S INST=DEFSITE
+ .S RCNT=0
+ .F  S RCNT=$O(REM(RCNT)) Q:'RCNT  D
+ ..S RIEN=$P(REM(RCNT),U),RNAM=$P(REM(RCNT),U,2),FRIEN=$P(REM(RCNT),U,3)
+ ..;Clear evaluation arrays.
+ ..K ^TMP("PXRHM",$J),^TMP("PXRMID",$J),FIEV
+ ..;Evaluate reminders and store results
+ ..D DEF^PXRMLDR(RIEN,.DEFARR)
+ ..D EVAL^PXRM(DFN,.DEFARR,1,1,.FIEV,PXRMDATE)
+ ..;Determine update from reminder status
+ ..S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAM)),U) I STATUS="" Q
+ ..;Ignore not applicables
+ ..S APPL=$S(STATUS["DUE":1,STATUS="RESOLVED":1,STATUS="DONE":1,1:0)
+ ..;Check if due
+ ..S DUE=$S(STATUS="DUE NOW":1,1:0)
+ ..;Compliance totals
+ ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT))
+ ..;Reminder ien
+ ..I $P(DATA,U)="" S $P(DATA,U)=RIEN
+ ..;Evaluated total
+ ..S $P(DATA,U,2)=$P(DATA,U,2)+1
+ ..;Applicable total
+ ..S $P(DATA,U,3)=$P(DATA,U,3)+APPL
+ ..;Not applicable total
+ ..I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+1
+ ..;Due total
+ ..S $P(DATA,U,5)=$P(DATA,U,5)+DUE
+ ..;Not due count
+ ..I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+1
+ ..;Add patient list
+ ..I $P(DATA,U,7)="" S $P(DATA,U,7)=PXRMLIST
+ ..;Update workfile
+ ..S ^TMP("PXRMETX",$J,SEQ,INST,RCNT)=DATA
+ ..;Save finding totals
+ ..I PARTYPE="CF" D FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP)
+ ;Clear evaluation fields
+ K ^TMP("PXRHM",$J),^TMP("PXRMID",$J)
+ ;S END=$H
+ ;W !,"REMINDER EVALUATION TIME"
+ ;D DETIME^PXRMXSEL(START,END)
+ Q
+ ;
+REMF(RIEN,RCNT,SEQ,REM) ;Build array of all findings in the reminder
+ N GNAM,GSEQ,FIND,FSEQ,GTYP,SUB
+ S GNAM="Finding totals",GSEQ="001",FSEQ=0,GTYP="MRF"
+ ;Save group name
+ S ^TMP("PXRMETX",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP
+ ;Select all findings in the reminder
+ S SUB=0
+ F  S SUB=$O(^PXD(811.9,RIEN,20,SUB)) Q:'SUB  D
+ .;Ignore if finding is not a term
+ .S FIND=$P($G(^PXD(811.9,RIEN,20,SUB,0)),U) Q:FIND'["PXRMD(811.5"
+ .;Convert to term ien
+ .S FIND=$P(FIND,";")
+ .;Build sequence number
+ .S FSEQ=FSEQ+1,FSEQ=$$RJ^XLFSTR(FSEQ,3,0)
+ .;Evaluation counts
+ .S REM(RCNT,FIND,GSEQ,FSEQ)=""
+ .S REM(RCNT,FIND,GSEQ)=GTYP
+ .;Update Workfile
+ .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND
+ Q
+ ;
+URCNT(PXRMSTRT,PXRMSTOP,TFIEVAL) ;
+ ;Handle counting all valid occurrences for the finding items.
+ ;Includes historical entries that were entered within the reporting
+ ;period, cut the encounter date if it is outside the reporting period.
+ N CNT,DATEENT,FDATE,FILE,FNUM,FOCCNUM,HIST,NODE,SCAT,VIEN
+ S CNT=0,FNUM=0
+ F  S FNUM=$O(TFIEVAL(FNUM)) Q:FNUM'>0  D
+ .S FILE=$G(TFIEVAL(FNUM,"FILE NUMBER"))
+ .S HIST=$S(FILE=9000010.18:1,FILE=9000010.13:1,FILE=9000010.23:1,FILE=9000010.16:1,FILE=9000010.07:1,FILE=9000010.12:1,FILE=9000010.15:1,1:0)
+ .S FOCCNUM=0 F  S FOCCNUM=$O(TFIEVAL(FNUM,FOCCNUM)) Q:FOCCNUM'>0  D
+ ..S FDATE=$P(TFIEVAL(FNUM,FOCCNUM,"DATE"),".") Q:FDATE'>0
+ ..I HIST=0,FDATE=PXRMSTRT!(FDATE>PXRMSTRT) S CNT=CNT+1
+ ..I HIST=1 D
+ ...S VIEN=TFIEVAL(FNUM,FOCCNUM,"VISIT") Q:VIEN'>0
+ ...S NODE=$G(^AUPNVSIT(VIEN,0))
+ ...S SCAT=$P(NODE,U,7),DATEENT=$P($P(NODE,U,2),".")
+ ...I FDATE=PXRMSTRT!(FDATE>PXRMSTRT),SCAT'="E" S CNT=CNT+1 Q
+ ...I SCAT="E",(DATEENT=PXRMSTRT!(DATEENT>PXRMSTRT))&(DATEENT=PXRMSTOP!(DATEENT<PXRMSTOP)) S CNT=CNT+1
+ D UPD(CNT)
+ Q
+ ;
+UPD(CNT) ;Update totals
+ S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ))
+ ;Total count
+ S $P(DATA,U,2)=$P(DATA,U,2)+CNT
+ ;Applicable count
+ S $P(DATA,U,3)=$P(DATA,U,3)+(APPL*CNT)
+ ;Not applicable count
+ I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+CNT
+ ;Due count
+ S $P(DATA,U,5)=$P(DATA,U,5)+(DUE*CNT)
+ ;Not due count
+ I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+CNT
+ ;Update current count
+ S ^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ)=DATA
+ ;AGP REMOVE UNTIL A DECISION CAN BE MADE
+ ;I CNT=1,APPL=1 S ^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)=DFN
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETXU.m

@@ -1 @@
-PXRMETXU        ; SLC/PJH - Extract utilities ;09/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
-        .S HTEXT(2)="use a different patient list name."
-        ;
-        I CALL=3 D
-        .S HTEXT(1)="Enter 'Y' to transmit extract. Otherwise enter 'N'."
-        ;
-        I CALL=4 D
-        .S HTEXT(1)="The selected period is the same as next scheduled extract."
-        .S HTEXT(2)="Enter 'Y' if this extract will replace the scheduled"
-        .S HTEXT(3)="extract. Enter 'N' if you still want the scheduled extract"
-        .S HTEXT(4)="to run."
-        ;
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-DELETE(IEN)     ;Delete an extract summary.
-        I IEN="" Q
-        N DA,DELOK,DIK,NAME
-        S DELOK=1
-        S NAME=$P(^PXRMXT(810.3,IEN,0),U,1)
-        ;Must have PXRM MANAGER key in order to delete national extracts.
-        I $P($G(^PXRMXT(810.3,IEN,100)),U,1)="N" D
-        . S DELOK=$S($D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0)
-        . I 'DELOK D
-        .. W !!,NAME," is national."
-        .. W !,"You cannot delete a national extract summary."
-        .. H 2
-        I 'DELOK Q
-        ;Double check the user really wants to delete.
-        S TEXT="Are you sure you want to delete "_NAME
-        S DELOK=$$ASKYN^PXRMEUT("N","Are you sure you want to delete "_NAME)
-        I 'DELOK Q
-        S DA=IEN
-        S DIK="^PXRMXT(810.3,"
-        D ^DIK
-        W !,"Deleting ",NAME
-        H 2
-        Q
-        ;
-PRGES   ;Delete any Extract Summaries over 5 years old
-        N DIFF,EDATE,OLD
-        S OLD=0
-        F  S OLD=$O(^PXRMXT(810.3,OLD)) Q:'OLD  D
-        .I +$G(^PXRMXT(810.3,OLD,50))'=1 Q
-        .;Extract Date
-        .S EDATE=$P($G(^PXRMXT(810.3,OLD,0)),U,6)
-        .;Ignore if < 5 years (1826 days) since creation
-        .I $$FMDIFF^XLFDT(DT,EDATE,1)<1826 Q
-        .;Otherwise delete
-        .N DIK,DA
-        .S DIK="^PXRMXT(810.3,",DA=OLD D ^DIK
-        Q
-        ;
-PRGPL   ;Delete any Patient Lists over 5 years old
-        N LDATE,OLD
-        S OLD=0
-        F  S OLD=$O(^PXRMXP(810.5,OLD)) Q:'OLD  D
-        .I +$G(^PXRMXP(810.5,OLD,50))'=1 Q
-        .;Patient List Date
-        .S LDATE=$P($G(^PXRMXP(810.5,OLD,0)),U,4)
-        .;Ignore if < 5 years (1826 days) since creation
-        .I $$FMDIFF^XLFDT(DT,LDATE,1)<1826 Q
-        .;Otherwise delete
-        .N DIK,DA
-        .S DIK="^PXRMXP(810.5,",DA=OLD D ^DIK
-        Q
-        ;
+PXRMETXU ; SLC/PJH - Extract utilities ;08/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
+ .S HTEXT(2)="use a different patient list name."
+ ;
+ I CALL=3 D
+ .S HTEXT(1)="Enter 'Y' to transmit extract. Otherwise enter 'N'."
+ ;
+ I CALL=4 D
+ .S HTEXT(1)="The selected period is the same as next scheduled extract."
+ .S HTEXT(2)="Enter 'Y' to if this extract will replace the scheduled"
+ .S HTEXT(3)="extract. Enter 'N' if you still want the scheduled extract"
+ .S HTEXT(3)="to run."
+ ;
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+PRGES ;Delete any Extract Summaries over 5 years old
+ N DIFF,EDATE,OLD
+ S OLD=0
+ F  S OLD=$O(^PXRMXT(810.3,OLD)) Q:'OLD  D
+ .I +$G(^PXRMXT(810.3,OLD,50))'=1 Q
+ .;Extract Date
+ .S EDATE=$P($G(^PXRMXT(810.3,OLD,0)),U,6)
+ .;Ignore if < 5 years (1826 days) since creation
+ .I $$FMDIFF^XLFDT(DT,EDATE,1)<1826 Q
+ .;Otherwise delete
+ .N DIK,DA
+ .S DIK="^PXRMXT(810.3,",DA=OLD D ^DIK
+ Q
+ ;
+PRGPL ;Delete any Patient Lists over 5 years old
+ N LDATE,OLD
+ S OLD=0
+ F  S OLD=$O(^PXRMXP(810.5,OLD)) Q:'OLD  D
+ .I +$G(^PXRMXP(810.5,OLD,50))'=1 Q
+ .;Patient List Date
+ .S LDATE=$P($G(^PXRMXP(810.5,OLD,0)),U,4)
+ .;Ignore if < 5 years (1826 days) since creation
+ .I $$FMDIFF^XLFDT(DT,LDATE,1)<1826 Q
+ .;Otherwise delete
+ .N DIK,DA
+ .S DIK="^PXRMXP(810.5,",DA=OLD D ^DIK
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEUT.m

@@ -1 @@
-PXRMEUT ; SLC/PJH - General extract utilities ;09/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=================================================
-ASKNUM(TEXT,MIN,MAX)    ;
-        N DIR,X,Y
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="N"_U_MIN_":"_MAX
-        S DIR("A")=TEXT
-        S DIR("B")=MIN
-        S DIR("?")="Enter a number between "_MIN_" and "_MAX_"."
-        W !
-        D ^DIR
-        I $D(DTOUT)!$D(DUOUT) S Y=MIN
-        Q Y
-        ;
-        ;=================================================
-ASKYN(DEF,TEXT,RTN,HLP) ;
-        N DIR,X,Y
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="Y0"
-        S DIR("A")=TEXT
-        S DIR("B")=DEF
-        S DIR("?")="Enter Y or N."
-        I $G(RTN)'="",$G(HLP)'="" D
-        . S DIR("?")="Enter Y or N. For detailed help type ??"
-        . S DIR("??")=U_"D HELP^"_RTN_"(HLP)"
-        W !
-        D ^DIR
-        I $D(DTOUT)!$D(DUOUT) S Y=DEF
-        Q Y
-        ;
-        ;=================================================
-BHELP   ;Write the beginning date help.
-        N BDHTEXT,%DT
-        S BDHTEXT(1)="This is the beginning date for the "_LIT_"."
-        D HELP^PXRMEUT(.BDHTEXT)
-        S %DT="P",%DT(0)=-DT
-        D HELP^%DTC
-        Q
-        ;
-        ;=================================================
-CALC(NEXT,START,END)    ;Calculate period start and end dates
-        ;Next is current run period
-        N CMON,CYR,ETYPE,NMON,NYR,PERIOD,YEAR
-        ;extract year and period (M1,M2,Q1,Q2,Y etc)
-        I NEXT["/" S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/"),ETYPE=$E(PERIOD)
-        I NEXT?4N S YEAR=NEXT,PERIOD="",ETYPE="Y"
-        ;Two digit year
-        S CYR=$E(YEAR,3,4),NYR=CYR
-        ;If yearly use Jan 1st of current year and next
-        I ETYPE="Y" D
-        .S CMON="1",NMON="1",NYR=NYR+1
-        ;If quarterly use start of first month of next quarter
-        I ETYPE="Q" D
-        .S CMON=$E(PERIOD,2,99),NMON=CMON*3+1 I NMON>12 S NYR=NYR+1,NMON=1
-        .S CMON=CMON*3-2
-        ;If monthly use start of next month
-        I ETYPE="M" D
-        .S CMON=$E(PERIOD,2,99),NMON=CMON+1 I NMON>12 S NYR=NYR+1,NMON=1
-        ;Zero fill the month fields
-        S CMON=$$RJ^XLFSTR(CMON,2,0),NMON=$$RJ^XLFSTR(NMON,2,0)
-        ;Zero fill the year fields
-        S CYR=$$RJ^XLFSTR(CYR,2,0),NYR=$$RJ^XLFSTR(NYR,2,0)
-        ;Report start date is start of current period 
-        S START=3_CYR_CMON_"01"
-        ;Report end date is start of next period less one day
-        S END=$$FMADD^XLFDT(3_NYR_NMON_"01",-1)
-        Q
-        ;
-        ;=================================================
-DATES(BDATE,EDATE,LIT)  ;Get a past date range.
-BEGIN   ;Select the beginning date.
-        N DIR,%DT,X,Y
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="DA^::ETX"
-        S DIR("A")="Enter "_LIT_" BEGINNING DATE: "
-        S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
-        S DIR("?")="For detailed help type ??"
-        S DIR("??")=U_"D BHELP^PXRMEUT"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        S BDATE=Y
-        I $E(Y,6,7)="00" W $C(7),"  ?? Enter exact date" G BEGIN
-        S BDATE=Y
-        ;
-END     ;Select the ending date.
-        S DIR(0)="DA^"_BDATE_"::ETX"
-        S DIR("A")="Enter "_LIT_" ENDING DATE: "
-        S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
-        S DIR("?")="This date cannot be before "_$$FMTE^XLFDT(BDATE,"D")_". For detailed help type ??"
-        S DIR("??")=U_"D EHELP^PXRMEUT"
-        D ^DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT) Q
-        I $D(DUOUT) G BEGIN
-        S EDATE=Y
-        I $E(Y,6,7)="00" W $C(7),"  ?? Enter exact date" G END
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        Q
-        ;
-        ;=================================================
-DOCUMENT(PXRMLIST,PXRMRULE,INDP,INTP,BEG,END)   ;Document how the
-        ;list was built.
-        N CDATE,CLASS,CREATOR,IND,LDATA,LNAME
-        N NDL,NL,NPAT,OUTPUT,SNAME,SOURCE,TEXT,TYPE,VALMCNT
-        K ^TMP("PXRMLRED",$J)
-        S LDATA=$G(^PXRMXP(810.5,PXRMLIST,0))
-        S LNAME=$P(LDATA,U,1)
-        S CDATE=$P(LDATA,U,4)
-        S SOURCE=$P(LDATA,U,5),SNAME="NONE"
-        ;Check if generated from #810.2
-        I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U)
-        ;If not check if generated from #810.4
-        I 'SOURCE S SOURCE=$P(LDATA,U,6) S:SOURCE SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U)
-        ;Creator
-        S CREATOR=+$P(LDATA,U,7)
-        S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None")
-        ;Type
-        S TYPE=$P(LDATA,U,8)
-        S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM)
-        ;Class
-        S CLASS=$P($G(^PXRMXP(810.5,PXRMLIST,100)),U,1)
-        S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local")
-        S NPAT=$P(^PXRMXP(810.5,PXRMLIST,30,0),U,4)
-        S TEXT(1)="List Name: "_LNAME_" ("_NPAT_" patients)"
-        S TEXT(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z")
-        S TEXT(2)=$$LJ^XLFSTR(TEXT(2),40)_"Creator: "_CREATOR
-        S TEXT(3)=" Class: "_CLASS
-        S TEXT(3)=$$LJ^XLFSTR(TEXT(3),40)_"Type: "_TYPE
-        S TEXT(4)=" Source: "_SNAME
-        S TEXT(5)=" Patient List Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z")
-        S TEXT(6)=" Patient List Ending Date: "_$$FMTE^XLFDT(END,"5Z")
-        S TEXT(7)=" "
-        S NL=7
-        F IND=1:1:NL S ^PXRMXP(810.5,PXRMLIST,200,IND,0)=TEXT(IND)
-        D BLDLIST^PXRMLRED(PXRMRULE,3)
-        F IND=1:1:VALMCNT S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=^TMP("PXRMLRED",$J,IND,0)
-        S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" --- List Build Information ---"
-        S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z")
-        S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Ending Date: "_$$FMTE^XLFDT(END,"5Z")
-        S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" "
-        S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include deceased patients: "_$S(INDP:"Yes",1:"No")
-        S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include test patients: "_$S(INTP:"Yes",1:"No")
-        ;Get the beginning and ending date information
-        D DOCDATES^PXRMEUT1(PXRMRULE,BEG,END,.NDL,.OUTPUT)
-        F IND=1:1:NDL S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=OUTPUT(IND)
-        S ^PXRMXP(810.5,PXRMLIST,200,0)=U_U_NL_U_NL_U_DT_U
-        K ^TMP("PXRMLRED",$J)
-        Q
-        ;
-        ;=================================================
-EHELP   ;Write the ending date help.
-        N EDHTEXT,%DT
-        S EDHTEXT(1)="This is the ending date for the "_LIT_"."
-        D HELP^PXRMEUT(.EDHTEXT)
-        S %DT="P",%DT(0)=-DT
-        D HELP^%DTC
-        Q
-        ;
-        ;=================================================
-HELP(HTEXT)     ;General help text output routine.
-        N IND,NIN,NOUT,TEXTIN,TEXOUT
-        ;Make sure the text is in a form the formatting routine can handle.
-        S IND="",NIN=0
-        F  S IND=$O(HTEXT(IND)) Q:IND=""  S NIN=NIN+1,TEXTIN(NIN)=HTEXT(IND)
-        D FORMAT^PXRMTEXT(1,72,NIN,.TEXTIN,.NOUT,.TEXTOUT)
-        F IND=1:1:NOUT W !,TEXTOUT(IND)
-        W !
-        Q
-        ;
-        ;=================================================
-LDELOK(LISTIEN) ;Return a 1 if it is ok for this user to delete the list.
-        N CREATOR,DELOK
-        S CREATOR=$P(^PXRMXP(810.5,LISTIEN,0),U,7)
-        S DELOK=$S(CREATOR=DUZ:1,$D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0)
-        Q DELOK
-        ;
-        ;=================================================
-MES(TEXT)       ;General mail message
-        N XMSUB
-        K ^TMP("PXRMXMZ",$J)
-        S XMSUB="CLINICAL REMINDER EXTRACT"
-        S ^TMP("PXRMXMZ",$J,1,0)=TEXT
-        D SEND^PXRMMSG(XMSUB)
-        Q
-        ;
-        ;=================================================
-PERIOD(FREQ)    ;Calculate next period
-        N CMON,CUR,CYR,ETYPE,NEXT,PERIOD,YEAR
-        ;Format current date YY/MM/DD
-        S CUR=$$FMTE^XLFDT($$NOW^XLFDT,7)
-        ;extract year and period
-        S YEAR=$P(CUR,"/"),PERIOD=$P(CUR,"/",2)
-        ;If yearly current year
-        I FREQ="Y" D
-        .S NEXT=YEAR
-        ;If quarterly use current quarter
-        I FREQ="Q" D
-        .S NEXT="Q"_((PERIOD-1\3)+1)_"/"_YEAR
-        ;If monthly use current month
-        I FREQ="M" D
-        .S NEXT="M"_PERIOD_"/"_YEAR
-        Q NEXT
-        ;
-        ;=================================================
-RMPAT(NODE,INDP,INTP)   ;Remove dead and test patients from
-        ;the list.
-        I INDP,INTP Q
-        N DFN,DOD,REMOVE
-        S DFN=0
-        F  S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN=""  D
-        .;DBIA 3744
-        . S REMOVE=$S('INTP:$$TESTPAT^VADPT(DFN),1:0)
-        . I REMOVE K ^TMP($J,NODE,DFN) Q
-        . I INDP Q
-        .;DBIA #10035
-        . S DOD=+$P($G(^DPT(DFN,.35)),U,1)
-        . I DOD=0 Q
-        . K ^TMP($J,NODE,DFN)
-        Q
-        ;
+PXRMEUT ; SLC/PJH - General extract utilities ;06/27/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=================================================
+ASKNUM(TEXT,MIN,MAX) ;
+ N DIR,X,Y
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="N"_U_MIN_":"_MAX
+ S DIR("A")=TEXT
+ S DIR("B")=MIN
+ S DIR("?")="Enter a number between "_MIN_" and "_MAX_"."
+ W !
+ D ^DIR
+ I $D(DTOUT)!$D(DUOUT) S Y=MIN
+ Q Y
+ ;
+ ;=================================================
+ASKYN(DEF,TEXT,RTN,HLP) ;
+ N DIR,X,Y
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="Y0"
+ S DIR("A")=TEXT
+ S DIR("B")=DEF
+ S DIR("?")="Enter Y or N."
+ I $G(RTN)'="",$G(HLP)'="" D
+ . S DIR("?")="Enter Y or N. For detailed help type ??"
+ . S DIR("??")=U_"D HELP^"_RTN_"(HLP)"
+ W !
+ D ^DIR
+ I $D(DTOUT)!$D(DUOUT) S Y=DEF
+ Q Y
+ ;
+ ;=================================================
+BHELP ;Write the beginning date help.
+ N BDHTEXT,%DT
+ S BDHTEXT(1)="This is the beginning date for the "_LIT_"."
+ D HELP^PXRMEUT(.BDHTEXT)
+ S %DT="P",%DT(0)=-DT
+ D HELP^%DTC
+ Q
+ ;
+ ;=================================================
+CALC(NEXT,START,END) ;Calculate period start and end dates
+ ;Next is current run period
+ N CMON,CYR,ETYPE,NMON,NYR,PERIOD,YEAR
+ ;extract year and period (M1,M2,Q1,Q2,Y etc)
+ I NEXT["/" S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/"),ETYPE=$E(PERIOD)
+ I NEXT?4N S YEAR=NEXT,PERIOD="",ETYPE="Y"
+ ;Two digit year
+ S CYR=$E(YEAR,3,4),NYR=CYR
+ ;If yearly use Jan 1st of current year and next
+ I ETYPE="Y" D
+ .S CMON="1",NMON="1",NYR=NYR+1
+ ;If quarterly use start of first month of next quarter
+ I ETYPE="Q" D
+ .S CMON=$E(PERIOD,2,99),NMON=CMON*3+1 I NMON>12 S NYR=NYR+1,NMON=1
+ .S CMON=CMON*3-2
+ ;If monthly use start of next month
+ I ETYPE="M" D
+ .S CMON=$E(PERIOD,2,99),NMON=CMON+1 I NMON>12 S NYR=NYR+1,NMON=1
+ ;Zero fill the month fields
+ S CMON=$$RJ^XLFSTR(CMON,2,0),NMON=$$RJ^XLFSTR(NMON,2,0)
+ ;Zero fill the year fields
+ S CYR=$$RJ^XLFSTR(CYR,2,0),NYR=$$RJ^XLFSTR(NYR,2,0)
+ ;Report start date is start of current period 
+ S START=3_CYR_CMON_"01"
+ ;Report end date is start of next period less one day
+ S END=$$FMADD^XLFDT(3_NYR_NMON_"01",-1)
+ Q
+ ;
+ ;=================================================
+DATES(BDATE,EDATE,LIT) ;Get a past date range.
+BEGIN ;Select the beginning date.
+ N DIR,%DT,X,Y
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="DA^::ETX"
+ S DIR("A")="Enter "_LIT_" BEGINNING DATE: "
+ S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
+ S DIR("?")="For detailed help type ??"
+ S DIR("??")=U_"D BHELP^PXRMEUT"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ S BDATE=Y
+ I $E(Y,6,7)="00" W $C(7),"  ?? Enter exact date" G BEGIN
+ S BDATE=Y
+ ;
+END ;Select the ending date.
+ S DIR(0)="DA^"_BDATE_"::ETX"
+ S DIR("A")="Enter "_LIT_" ENDING DATE: "
+ S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
+ S DIR("?")="This date cannot be before "_$$FMTE^XLFDT(BDATE,"D")_". For detailed help type ??"
+ S DIR("??")=U_"D EHELP^PXRMEUT"
+ D ^DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT) Q
+ I $D(DUOUT) G BEGIN
+ S EDATE=Y
+ I $E(Y,6,7)="00" W $C(7),"  ?? Enter exact date" G END
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ Q
+ ;
+ ;=================================================
+DOCUMENT(PXRMLIST,PXRMRULE,INDP,INTP,BEG,END) ;Document how the
+ ;list was built.
+ N CDATE,CLASS,CREATOR,IND,LDATA,LNAME
+ N NDL,NL,NPAT,OUTPUT,SNAME,SOURCE,TEXT,TYPE,VALMCNT
+ K ^TMP("PXRMLRED",$J)
+ S LDATA=$G(^PXRMXP(810.5,PXRMLIST,0))
+ S LNAME=$P(LDATA,U,1)
+ S CDATE=$P(LDATA,U,4)
+ S SOURCE=$P(LDATA,U,5),SNAME="NONE"
+ ;Check if generated from #810.2
+ I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U)
+ ;If not check if generated from #810.4
+ I 'SOURCE S SOURCE=$P(LDATA,U,6) S:SOURCE SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U)
+ ;Creator
+ S CREATOR=+$P(LDATA,U,7)
+ S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None")
+ ;Type
+ S TYPE=$P(LDATA,U,8)
+ S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM)
+ ;Class
+ S CLASS=$P($G(^PXRMXP(810.5,PXRMLIST,100)),U,1)
+ S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local")
+ S NPAT=$P(^PXRMXP(810.5,PXRMLIST,30,0),U,4)
+ S TEXT(1)="List Name: "_LNAME_" ("_NPAT_" patients)"
+ S TEXT(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z")
+ S TEXT(2)=$$LJ^XLFSTR(TEXT(2),40)_"Creator: "_CREATOR
+ S TEXT(3)=" Class: "_CLASS
+ S TEXT(3)=$$LJ^XLFSTR(TEXT(3),40)_"Type: "_TYPE
+ S TEXT(4)=" Source: "_SNAME
+ S TEXT(5)=" Patient List Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z")
+ S TEXT(6)=" Patient List Ending Date: "_$$FMTE^XLFDT(END,"5Z")
+ S TEXT(7)=" "
+ S NL=7
+ F IND=1:1:NL S ^PXRMXP(810.5,PXRMLIST,200,IND,0)=TEXT(IND)
+ D BLDLIST^PXRMLRED(PXRMRULE,3)
+ F IND=1:1:VALMCNT S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=^TMP("PXRMLRED",$J,IND,0)
+ S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" --- List Build Information ---"
+ S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z")
+ S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Ending Date: "_$$FMTE^XLFDT(END,"5Z")
+ S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" "
+ S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include deceased patients: "_$S(INDP:"Yes",1:"No")
+ S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include test patients: "_$S(INTP:"Yes",1:"No")
+ ;Get the beginning and ending date information
+ D DOCDATES^PXRMEUT1(PXRMRULE,BEG,END,.NDL,.OUTPUT)
+ F IND=1:1:NDL S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=OUTPUT(IND)
+ S ^PXRMXP(810.5,PXRMLIST,200,0)=U_U_NL_U_NL_U_DT_U
+ K ^TMP("PXRMLRED",$J)
+ Q
+ ;
+ ;=================================================
+EHELP ;Write the ending date help.
+ N EDHTEXT,%DT
+ S EDHTEXT(1)="This is the ending date for the "_LIT_"."
+ D HELP^PXRMEUT(.EDHTEXT)
+ S %DT="P",%DT(0)=-DT
+ D HELP^%DTC
+ Q
+ ;
+ ;=================================================
+HELP(HTEXT) ;General help text routine. Write out the text in the HTEXT
+ ;array.
+ N DIWF,DIWL,DIWR,IC,X
+ S DIWF="C70",DIWL=0,DIWR=70
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
+ W !
+ Q
+ ;
+ ;=================================================
+LDELOK(LISTIEN) ;Return a 1 if it is ok for this user to delete the list.
+ N CREATOR,DELOK
+ S CREATOR=$P(^PXRMXP(810.5,LISTIEN,0),U,7)
+ S DELOK=$S(CREATOR=DUZ:1,$D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0)
+ Q DELOK
+ ;
+ ;=================================================
+MES(TEXT) ;General mail message
+ N XMSUB
+ K ^TMP("PXRMXMZ",$J)
+ S XMSUB="CLINICAL REMINDER EXTRACT"
+ S ^TMP("PXRMXMZ",$J,1,0)=TEXT
+ D SEND^PXRMMSG(XMSUB)
+ Q
+ ;
+ ;=================================================
+PERIOD(FREQ) ;Calculate next period
+ N CMON,CUR,CYR,ETYPE,NEXT,PERIOD,YEAR
+ ;Format current date YY/MM/DD
+ S CUR=$$FMTE^XLFDT($$NOW^XLFDT,7)
+ ;extract year and period
+ S YEAR=$P(CUR,"/"),PERIOD=$P(CUR,"/",2)
+ ;If yearly current year
+ I FREQ="Y" D
+ .S NEXT=YEAR
+ ;If quarterly use current quarter
+ I FREQ="Q" D
+ .S NEXT="Q"_((PERIOD-1\3)+1)_"/"_YEAR
+ ;If monthly use current month
+ I FREQ="M" D
+ .S NEXT="M"_PERIOD_"/"_YEAR
+ Q NEXT
+ ;
+ ;=================================================
+RMPAT(NODE,INDP,INTP) ;Remove dead and test patients from
+ ;the list.
+ I INDP,INTP Q
+ N DFN,DOD,REMOVE
+ S DFN=0
+ F  S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN=""  D
+ .;DBIA 3744
+ . S REMOVE=$S('INTP:$$TESTPAT^VADPT(DFN),1:0)
+ . I REMOVE K ^TMP($J,NODE,DFN) Q
+ . I INDP Q
+ .;DBIA #10035
+ . S DOD=+$P($G(^DPT(DFN,.35)),U,1)
+ . I DOD=0 Q
+ . K ^TMP($J,NODE,DFN)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m

@@ -1 @@
-PXRMEUT1        ; SLC/PKR - General extract utilities ;05/08/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;=================================================
-CLDATES ;Cleanup entries in ^TMP("PXRMDDOC",$J) before making date checks.
-        ;For drug findings consolidate PS(55, PS(55NVA, and PSRX( back to
-        ;PSDRUG(.
-        N FI,FIND0,ITEM,GLOBAL,LIST
-        S FIND0=""
-        F  S FIND0=$O(^TMP("PXRMDDOC",$J,FIND0)) Q:FIND0=""  D
-        . S FI=$P(FIND0,U,1)
-        . S GLOBAL=$P(FI,";",2)
-        . I GLOBAL'["PS" Q
-        . S GLOBAL="PSDRUG("
-        . S ITEM=$P(FI,";",1)
-        . S FI=ITEM_";"_GLOBAL_U_$P(FIND0,U,2,11)
-        . S LIST(FIND0)=FI
-        ;
-        S FIND0=""
-        F  S FIND0=$O(LIST(FIND0)) Q:FIND0=""  D
-        . S FI=LIST(FIND0)
-        . S ^TMP("PXRMDDOC",$J,FI)=^TMP("PXRMDDOC",$J,FIND0)
-        . K ^TMP("PXRMDDOC",$J,FIND0)
-        Q
-        ;
-        ;=================================================
-DAYSIM(FMDATE)  ;Given a FileMan date return the number of days in the month.
-        N MONTH
-        S MONTH=$E(FMDATE,4,5)
-        S DAYS=$S(MONTH="01":31,MONTH="02":28,MONTH="03":31,MONTH="04":30,MONTH="05":31,MONTH="06":30,MONTH="07":31,MONTH="08":31,MONTH="09":30,MONTH="10":31,MONTH="11":30,MONTH="12":31,1:"")
-        I MONTH="02" D
-        . N LYEAR,YEAR
-        . S YEAR=$E(FMDATE,1,3)+1700
-        . S LYEAR=$S((YEAR#4=0)&(YEAR#100'=0):1,YEAR#400=0:1,1:0)
-        . I LYEAR S DAYS=29
-        Q DAYS
-        ;
-        ;=================================================
-DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
-        I DATE=0 Q DATE
-        N PXRMDATE
-        S PXRMDATE=$S(DATE["BDT":LBBDT,1:LBEDT)
-        S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
-        Q $$CTFMD^PXRMDATE(DATE)
-        ;
-        ;=================================================
-DOCDATES(RULESET,LBBDT,LBEDT,NL,OUTPUT) ;
-        N EM,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
-        N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,OPER,PXRMFVPL
-        N RRIEN,RSDATA,RSDATES,RBDT,REDT,SEQ,SUB
-        I $G(PXRMDDOC)=2 D CLDATES
-        ;Build the variable pointer list.
-        D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
-        S SEQ="",NL=0
-        F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
-        . S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
-        . S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
-        . S OPER=$P(RSDATA,U,3)
-        . S OPER=$$EXTERNAL^DILFD(810.41,.03,"",OPER,.EM)
-        . S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
-        .;Finding rule ien.
-        . S FRIEN=$P(RSDATA,U,2) Q:'FRIEN
-        .;Check if entry is a finding rule (not a set or reminder rule)
-        . S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
-        . S FRDATES=$P(FRDATA,U,4,5)
-        .;Get term IEN for finding rule
-        . I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
-        .;Get Reminder definition IEN for Reminder rule
-        . I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
-        .;Determine RBDT and REDT
-        . D RDATES(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
-        . S NL=NL+1,OUTPUT(NL)=""
-        . S NL=NL+1,OUTPUT(NL)="SEQUENCE "_SEQ_" "_$P(FRDATA,U,1)
-        . S NL=NL+1,OUTPUT(NL)=" Operation: "_OPER
-        .;Term finding rules
-        . I FRTYP=1 D TERM(FRTIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
-        .;Reminder Definition List Rule
-        . I FRTYP=2 D REM(RRIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
-        Q
-        ;
-        ;=================================================
-FMULPRT(FARR,PXRMFVPL,NL,OUTPUT)        ;Print the finding multiple
-        ;information.
-        ;Q
-        N BDT,EDT,DERROR,FNAME,FTYPE,IND,NOCC,TBDT,TEDT,TEMP,VPTR
-        S IND=0
-        F  S IND=+$O(FARR(20,IND)) Q:IND=0  D
-        . S VPTR=$P(FARR(20,IND,0),U,1)
-        . S FNAME=$$ENTRYNAM^PXRMPTD2(VPTR)
-        . S FTYPE=$$FTYPE^PXRMPTD2(VPTR,1)
-        . S NL=NL+1,OUTPUT(NL)="  FINDING "_IND_"-"_FTYPE_"."_FNAME
-        .;Set the finding parameters.
-        . D SSPAR^PXRMUTIL(FARR(20,IND,0),.NOCC,.BDT,.EDT)
-        . S NL=NL+1,OUTPUT(NL)="   Beginning Date/Time: "_$$FMTE^XLFDT(BDT,"5Z")
-        . S NL=NL+1,OUTPUT(NL)="   Ending Date/Time:    "_$$FMTE^XLFDT(EDT,"5Z")
-        . I $G(PXRMDDOC)'=2 Q
-        . S DERROR=0
-        . S TEMP=$G(^TMP("PXRMDDOC",$J,$P(FARR(20,IND,0),U,1,11)))
-        .;If TEMP is null then no evaluation was required and the check 
-        .;cannot be made
-        . I TEMP="" Q
-        . I $P(TEMP,U,1)'=BDT D
-        .. S DERROR=1
-        .. S NL=NL+1,OUTPUT(NL)="  There is a consistency problem with the beginning date!"
-        .. S NL=NL+1,OUTPUT(NL)="  Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,1),"5Z")
-        . I $P(TEMP,U,2)'=EDT D
-        .. S DERROR=1
-        .. S NL=NL+1,OUTPUT(NL)="  There is a consistency problem with the ending date!"
-        .. S NL=NL+1,OUTPUT(NL)="  Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,2),"5Z")
-        . I DERROR D
-        .. S NL=NL+1,OUTPUT(NL)="  Please notify the developers."
-        .. ;S NL=NL+1,OUTPUT(NL)="  Please enter a Remedy ticket."
-        .. S NL=NL+1,OUTPUT(NL)=" "
-        Q
-        ;
-        ;=================================================
-RDATES(RSDATES,FRDATES,LBBDT,LBEDT,RBDT,REDT)   ;Determine the beginning and
-        ;ending dates.
-        ;Date precedence: LIST BUILD < RULE SET < FINDING RULE < TERM/REMINDER
-        S RBDT=$P(FRDATES,U,1),REDT=$P(FRDATES,U,2)
-        I RBDT="",REDT="" S RBDT=$P(RSDATES,U,1),REDT=$P(RSDATES,U,2)
-        I RBDT="",REDT="" S RBDT=LBBDT,REDT=LBEDT
-        I RBDT="" S RBDT=0
-        I REDT="" S REDT=LBEDT
-        I REDT=0 S REDT=DT
-        ;Convert RBDT and REDT to FileMan dates.
-        S RBDT=$$DCONV(RBDT,LBBDT,LBEDT)
-        S REDT=$$DCONV(REDT,LBBDT,LBEDT)
-        ;If the month is missing use January for the beginning date and
-        ;December for the ending date.
-        I $E(RBDT,4,5)="00" S RBDT=$E(RBDT,1,3)_"01"_$E(RBDT,6,7)
-        I $E(REDT,4,5)="00" S REDT=$E(REDT,1,3)_"12"_$E(REDT,6,7)
-        ;If the day is missing use the first for beginning date and the end
-        ;of the month for ending date.
-        I $E(RBDT,6,7)="00" S RBDT=$E(RBDT,1,5)_"01"
-        I $E(REDT,6,7)="00" S REDT=$E(REDT,1,5)_$$DAYSIM(REDT)
-        Q
-        ;
-        ;=================================================
-REM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT)       ;
-        N DEFARR
-        D DEF^PXRMLDR(IEN,.DEFARR)
-        D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.DEFARR)
-        S NL=NL+1,OUTPUT(NL)=" REMINDER DEFINITION "_$P(DEFARR(0),U,1)
-        D FMULPRT(.DEFARR,.PXRMFVPL,.NL,.OUTPUT)
-        Q
-        ;
-        ;=================================================
-TERM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT)      ;
-        N TERMARR
-        D TERM^PXRMLDR(IEN,.TERMARR)
-        D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.TERMARR)
-        S NL=NL+1,OUTPUT(NL)=" TERM "_$P(TERMARR(0),U,1)
-        D FMULPRT(.TERMARR,.PXRMFVPL,.NL,.OUTPUT)
-        Q
-        ;
+PXRMEUT1 ; SLC/PKR - General extract utilities ;08/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;=================================================
+DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
+ I DATE=0 Q DATE
+ N PXRMDATE
+ S PXRMDATE=$S(DATE["BDT":LBBDT,1:LBEDT)
+ S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
+ Q $$CTFMD^PXRMDATE(DATE)
+ ;
+ ;=================================================
+DAYSIM(FMDATE) ;Given a FileMan date return the number of days in the month.
+ N MONTH
+ S MONTH=$E(FMDATE,4,5)
+ S DAYS=$S(MONTH="01":31,MONTH="02":28,MONTH="03":31,MONTH="04":30,MONTH="05":31,MONTH="06":30,MONTH="07":31,MONTH="08":31,MONTH="09":30,MONTH="10":31,MONTH="11":30,MONTH="12":31,1:"")
+ I MONTH="02" D
+ . N LYEAR,YEAR
+ . S YEAR=$E(FMDATE,1,3)+1700
+ . S LYEAR=$S((YEAR#4=0)&(YEAR#100'=0):1,YEAR#400=0:1,1:0)
+ . I LYEAR S DAYS=29
+ Q DAYS
+ ;
+ ;=================================================
+DOCDATES(RULESET,LBBDT,LBEDT,NL,OUTPUT) ;
+ N FINDPA,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,PXRMDATE,PXRMFVPL
+ N RRIEN,RSDATA,RSDATES,RBDT,REDT,SEQ,SUB
+ ;Build the variable pointer list.
+ D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
+ S SEQ="",NL=0
+ F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
+ . S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
+ . S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
+ . S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
+ .;Finding rule ien.
+ . S FRIEN=$P(RSDATA,U,2) Q:'FRIEN
+ .;Check if entry is a finding rule (not a set or reminder rule)
+ . S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
+ . S FRDATES=$P(FRDATA,U,4,5)
+ .;Get term IEN for finding rule
+ . I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
+ .;Get Reminder definition IEN for Reminder rule
+ . I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
+ .;Determine RBDT and REDT
+ . D RDATES(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
+ . S PXRMDATE=LBEDT
+ . S $P(FINDPA(0),U,8)=RBDT,$P(FINDPA(0),U,11)=REDT
+ . S NL=NL+1,OUTPUT(NL)=""
+ . S NL=NL+1,OUTPUT(NL)="SEQUENCE "_SEQ_" "_$P(FRDATA,U,1)
+ .;Term finding rules
+ . I FRTYP=1 D TERM(FRTIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
+ .;Reminder Definition List Rule
+ . I FRTYP=2 D REM(RRIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
+ Q
+ ;
+ ;=================================================
+FMULPRT(DEFARR,FINDPA,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple
+ ;information.
+ N BDT,EDT,FNAME,FTYPE,IND,NOCC,PFINDPA,TFINDPA,VPTR
+ S IND=0
+ F  S IND=+$O(DEFARR(20,IND)) Q:IND=0  D
+ . S VPTR=$P(DEFARR(20,IND,0),U,1)
+ . S FNAME=$$ENTRYNAM^PXRMPTD2(VPTR)
+ . S FTYPE=$$FTYPE^PXRMPTD2(VPTR,1)
+ . S NL=NL+1,OUTPUT(NL)="  FINDING "_IND_"-"_FTYPE_"."_FNAME
+ . K PFINDPA,TFINDPA
+ . M TFINDPA=DEFARR(20,IND)
+ .;Set the finding parameters.
+ . D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ . D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ . S NL=NL+1,OUTPUT(NL)="   Beginning Date/Time: "_$$FMTE^XLFDT(BDT,"5Z")
+ . S NL=NL+1,OUTPUT(NL)="   Ending Date/Time:    "_$$FMTE^XLFDT(EDT,"5Z")
+ Q
+ ;
+ ;=================================================
+RDATES(RSDATES,FRDATES,LBBDT,LBEDT,RBDT,REDT) ;Determine the beginning and
+ ;ending dates.
+ ;Date precedence: LIST BUILD < RULE SET < FINDING RULE < TERM/REMINDER
+ S RBDT=$P(FRDATES,U,1),REDT=$P(FRDATES,U,2)
+ I RBDT="",REDT="" S RBDT=$P(RSDATES,U,1),REDT=$P(RSDATES,U,2)
+ I RBDT="",REDT="" S RBDT=LBBDT,REDT=LBEDT
+ I RBDT="" S RBDT=0
+ I REDT="" S REDT=LBEDT
+ I REDT=0 S REDT=$$DT^XLFDT
+ ;Convert RBDT and REDT to FileMan dates.
+ S RBDT=$$DCONV(RBDT,LBBDT,LBEDT)
+ S REDT=$$DCONV(REDT,LBBDT,LBEDT)
+ ;If the month is missing use January for the beginning date and
+ ;December for the ending date.
+ I $E(RBDT,4,5)="00" S RBDT=$E(RBDT,1,3)_"01"_$E(RBDT,6,7)
+ I $E(REDT,4,5)="00" S REDT=$E(REDT,1,3)_"12"_$E(REDT,6,7)
+ ;If the day is missing use the first for beginning date and the end
+ ;of the month for ending date.
+ I $E(RBDT,6,7)="00" S RBDT=$E(RBDT,1,5)_"01"
+ I $E(REDT,6,7)="00" S REDT=$E(REDT,1,5)_$$DAYSIM(REDT)
+ Q
+ ;
+ ;=================================================
+REM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ;
+ N DEFARR
+ D DEF^PXRMLDR(IEN,.DEFARR)
+ S NL=NL+1,OUTPUT(NL)=" REMINDER DEFINITION "_$P(DEFARR(0),U,1)
+ D FMULPRT(.DEFARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
+ Q
+ ;
+ ;=================================================
+TERM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ;
+ N TERMARR
+ D TERM^PXRMLDR(IEN,.TERMARR)
+ S NL=NL+1,OUTPUT(NL)=" TERM "_$P(TERMARR(0),U,1)
+ D FMULPRT(.TERMARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m

@@ -1 @@
-PXRMEVFI        ; SLC/PKR - Driver for finding evaluation. ;04/02/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=====================================================
-EVAL(DFN,DEFARR,FIEVAL) ;Evaluate the findings by group using the "E"
-        ;index.
-        N ENODE
-        S ENODE=""
-        F  S ENODE=$O(DEFARR("E",ENODE)) Q:ENODE=""  D
-        . I ENODE="AUTTEDT(" D EVALFI^PXRMEDU(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="AUTTEXAM(" D EVALFI^PXRMEXAM(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="AUTTHF(" D EVALFI^PXRMHF(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="AUTTIMM(" D EVALFI^PXRMIMM(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="AUTTSK(" D EVALFI^PXRMSKIN(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="GMRD(120.51," D EVALFI^PXRMVITL(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="LAB(60," D EVALFI^PXRMLAB(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="ORD(101.43," D EVALFI^PXRMORDR(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="PXD(811.2," D EVALFI^PXRMTAX(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="PXRMD(810.9," D EVALFI^PXRMLOCF(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="PXRMD(811.4," D EVALFI^PXRMCF(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="PXRMD(811.5," D EVALFI^PXRMTERM(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="PS(50.605," D EVALFI^PXRMDRCL(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="PSDRUG(" D EVALFI^PXRMDRUG(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="PSNDF(50.6," D EVALFI^PXRMDGEN(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="RAMIS(71," D EVALFI^PXRMRAD(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        . I ENODE="YTT(601.71," D EVALFI^PXRMMH(DFN,.DEFARR,ENODE,.FIEVAL) Q
-        ;Evaluate function findings.
-        D EVAL^PXRMFF(DFN,.DEFARR,.FIEVAL)
-        Q
-        ;
-        ;=====================================================
-EVALPL(DEFARR,FINUM,PLIST)      ;Create a patient list for a regular
-        ;finding.
-        N FINDPA,TERMARR
-        S FINDPA(0)=DEFARR(20,FINUM,0)
-        S FINDPA(3)=DEFARR(20,FINUM,3)
-        S FINDPA(10)=DEFARR(20,FINUM,10)
-        S FINDPA(11)=DEFARR(20,FINUM,11)
-        D GENTERM^PXRMPLST(FINDPA(0),FINUM,.TERMARR)
-        D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PLIST)
-        Q
-        ;
+PXRMEVFI ; SLC/PKR - Driver for finding evaluation. ;12/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=====================================================
+EVAL(DFN,DEFARR,FIEVAL) ;Evaluate the findings by group using the "E"
+ ;index.
+ N ENODE
+ S ENODE=""
+ F  S ENODE=$O(DEFARR("E",ENODE)) Q:ENODE=""  D
+ . I ENODE="AUTTEDT(" D EVALFI^PXRMEDU(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="AUTTEXAM(" D EVALFI^PXRMEXAM(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="AUTTHF(" D EVALFI^PXRMHF(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="AUTTIMM(" D EVALFI^PXRMIMM(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="AUTTSK(" D EVALFI^PXRMSKIN(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="GMRD(120.51," D EVALFI^PXRMVITL(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="LAB(60," D EVALFI^PXRMLAB(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="ORD(101.43," D EVALFI^PXRMORDR(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="PXD(811.2," D EVALFI^PXRMTAX(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="PXRMD(810.9," D EVALFI^PXRMLOCF(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="PXRMD(811.4," D EVALFI^PXRMCF(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="PXRMD(811.5," D EVALFI^PXRMTERM(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="PS(50.605," D EVALFI^PXRMDRCL(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="PSDRUG(" D EVALFI^PXRMDRUG(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="PSNDF(50.6," D EVALFI^PXRMDGEN(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="RAMIS(71," D EVALFI^PXRMRAD(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="YTT(601," D EVALFI^PXRMMH(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ ;Evaluate function findings.
+ D EVAL^PXRMFF(DFN,.DEFARR,.FIEVAL)
+ Q
+ ;
+ ;=====================================================
+EVALPL(DEFARR,FINUM,PLIST) ;Create a patient list for a regular
+ ;finding.
+ N FINDPA,TERMARR
+ S FINDPA(0)=DEFARR(20,FINUM,0)
+ S FINDPA(3)=DEFARR(20,FINUM,3)
+ S FINDPA(10)=DEFARR(20,FINUM,10)
+ S FINDPA(11)=DEFARR(20,FINUM,11)
+ D GENTERM^PXRMPLST(FINDPA(0),FINUM,.TERMARR)
+ D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PLIST)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m

@@ -1 @@
-PXRMEXCF        ; SLC/PKR - Reminder exchange routines for computed findings. ;06/28/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;==============================================
-EXISTS(ROUTINE) ;Return true if routine ROUTINE exists.
-        I ROUTINE="" Q 0
-        N RTN
-        S RTN="^"_ROUTINE
-        Q $S($T(@RTN)'="":1,1:0)
-        ;
-        ;==============================================
-GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS)        ;Get the action for a routine.
-        N ACTION,CHOICES,CSUM,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
-        N PCS,ROUTINE,SAME,TEXT,X,Y
-        S NEWNAME=""
-        S ROUTINE=ATTR("NAME")
-        I EXISTS="" S EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
-        S CHOICES=$S(EXISTS:"COQS",1:"CIQS")
-        I EXISTS D
-        .;If the routine exists compare the existing routine checksum with the
-        .;the checksum of the routine in the packed definition.
-        . S CSUM=$$RTNCS^PXRMEXCS(ROUTINE)
-        . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
-        . S TEXT(1)="Routine "_ROUTINE_" already exists "
-        . I SAME D
-        .. S TEXT(1)=TEXT(1)_"and the packed routine is identical, skipping."
-        .. W !,TEXT(1),! H 2
-        .. S ACTION="S"
-        . I 'SAME D
-        .. S TEXT(1)=TEXT(1)_"but the packed routine is different,"
-        .. S TEXT(2)="what do you want to do?"
-        .. W !,TEXT(1),!,TEXT(2)
-        .. S DIR("B")="O"
-        .. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
-        E  D
-        . W !!,"Routine "_ROUTINE_" is new, what do you want to do?"
-        . S DIR("B")="I"
-        . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
-        ;
-        I (ACTION="Q")!(ACTION="S") Q ACTION
-        ;
-        I ACTION="C" D
-        . N CDONE
-        . S CDONE=0
-        . F  Q:CDONE  D
-        .. S NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
-        .. I NEWNAME="" S ACTION="S",CDONE=1 Q
-        .. S EXISTS=$$EXISTS^PXRMEXCF(NEWNAME)
-        .. I EXISTS W !,"Routine ",NEWNAME," already exists, try again."
-        .. E  D  Q
-        ... S CDONE=1
-        ... S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
-        ;
-        I (ACTION="I")&(EXISTS) D
-        .;If the action is overwrite double check that overwrite is what the
-        .;user really wants to do.
-        . K DIR
-        . S DIR(0)="Y"_U_"A"
-        . S DIR("A")="Are you sure you want to overwrite"
-        . S DIR("B")="N"
-        . D ^DIR
-        . I $D(DIROUT)!$D(DIRUT) S Y=0
-        . I $D(DTOUT)!$D(DUOUT) S Y=0
-        . I 'Y S ACTION="S"
-        . S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
-        Q ACTION
-        ;
+PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;==============================================
+EXISTS(ROUTINE) ;Return true if routine ROUTINE exists.
+ I ROUTINE="" Q 0
+ N RTN
+ S RTN="^"_ROUTINE
+ Q $S($T(@RTN)'="":1,1:0)
+ ;
+ ;==============================================
+GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS) ;Get the action for a routine.
+ N ACTION,CHOICES,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
+ N PCS,ROUTINE,SAME,TEXT,X,Y
+ S NEWNAME=""
+ ;If the routine exists compare the existing routine checksum with the
+ ;the checksum of the routine in the packed definition.
+ S ROUTINE=ATTR("NAME")
+ I EXISTS="" S EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
+ S CHOICES=$S(EXISTS:"COQS",1:"CIQS")
+ I EXISTS D
+ . S SAME=$$SAME(.ATTR,.RTN)
+ . S TEXT(1)="Routine "_ROUTINE_" already exists "
+ . I SAME S TEXT(1)=TEXT(1)_"and the packed routine is identical,"
+ . I 'SAME S TEXT(1)=TEXT(1)_"but the packed routine is different,"
+ . S TEXT(2)="what do you want to do?"
+ . D EN^DDIOL(.TEXT)
+ . S DIR("B")="S"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ E  D
+ . W !!,"Routine "_ROUTINE_" is NEW, what do you want to do?"
+ . S DIR("B")="I"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ ;
+ I ACTION="Q" Q ACTION
+ ;
+ I ACTION="C" D
+ . N CDONE
+ . S CDONE=0
+ . F  Q:CDONE  D
+ .. S NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
+ .. I NEWNAME="" S ACTION="S",CDONE=1 Q
+ .. S EXISTS=$$EXISTS^PXRMEXCF(NEWNAME)
+ .. I EXISTS W !,"Routine ",NEWNAME," already exists, try again."
+ .. E  D  Q
+ ... S CDONE=1
+ ... S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
+ ;
+ I (ACTION="I")&(EXISTS) D
+ .;If the action is overwrite double check that overwrite is what the
+ .;user really wants to do.
+ . K DIR
+ . S DIR(0)="Y"_U_"A"
+ . S DIR("A")="Are you sure you want to overwrite"
+ . S DIR("B")="N"
+ . D ^DIR
+ . I $D(DIROUT)!$D(DIRUT) S Y=0
+ . I $D(DTOUT)!$D(DUOUT) S Y=0
+ . I 'Y S ACTION="S"
+ . S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME
+ Q ACTION
+ ;
+ ;==============================================
+SAME(ATTR,RTN) ;Compare the existing routine and the new version
+ ;in RTN to see if they are the same.
+ N ECS,DIF,NEWCS,RT,SAME,X,XCNP
+ ;Load the existing routine into RT.
+ S XCNP=0
+ S DIF="RT("
+ S X=ATTR("NAME")
+ X ^%ZOSF("LOAD")
+ S ECS=$$ROUTINE^PXRMEXCS(.RT)
+ K RT
+ S NEWCS=$$ROUTINE^PXRMEXCS(.RTN)
+ S SAME=$S(ECS=NEWCS:1,1:0)
+ Q SAME
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m

@@ -1 @@
-PXRMEXCS        ; SLC/PKR - Routines to compute checksums. ;07/27/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;====================================================
-CHECKSUM(ATTR,START,END)        ;Get the the checksum for a packed reminder
-        ;component and load it into the attribute array.
-        N CS,LINE
-        ;If checksum is in packed component return it otherwise calculate it.
-        I ATTR("FILE NUMBER")=0 D
-        . S LINE=^PXD(811.8,PXRMRIEN,100,START-3,0)
-        . S CS=$$GETTAGV^PXRMEXU3(LINE,"<CHECKSUM>")
-        . I CS="" S CS=$$PRTNCS(PXRMRIEN,START,END)
-        I ATTR("FILE NUMBER")>0 D
-        . S LINE=^PXD(811.8,PXRMRIEN,100,START-2,0)
-        . S CS=$$GETTAGV^PXRMEXU3(LINE,"<CHECKSUM>")
-        . I CS="" S CS=$$PFDACS(PXRMRIEN,START,END)
-        S ATTR("CHECKSUM")=CS
-        Q
-        ;
-        ;====================================================
-DIQOUTCS(DIQOUT)        ;Return checksum for a processed DIQOUT array.
-        N CS,DATA,FIELD,FNUM,IENS,IND,SFN,STRING,TARGET,TEXT,WP
-        S FNUM=$O(DIQOUT(""))
-        D FIELD^DID(FNUM,"EDIT HISTORY","","SPECIFIER","TARGET")
-        S SFN=+$G(TARGET("SPECIFIER"))
-        S (CS,FNUM)=0
-        F  S FNUM=$O(DIQOUT(FNUM)) Q:FNUM=""  D
-        . I FNUM=SFN Q
-        . S IENS=""
-        . F  S IENS=$O(DIQOUT(FNUM,IENS)) Q:IENS=""  D
-        .. S FIELD=0
-        .. F  S FIELD=$O(DIQOUT(FNUM,IENS,FIELD)) Q:FIELD=""  D
-        ... S DATA=DIQOUT(FNUM,IENS,FIELD)
-        ... S TEXT=FNUM_$L(IENS,",")_FIELD_DATA
-        ... S CS=$$CRC32^XLFCRC(TEXT,CS)
-        ... I DATA["WP-start" F IND=1:1:$P(DATA,"~",2) D
-        .... S TEXT=DIQOUT(FNUM,IENS,FIELD,IND)
-        .... S CS=$$CRC32^XLFCRC(TEXT,CS)
-        Q CS
-        ;
-        ;====================================================
-FILE(FILENUM,IEN)       ;Return checksum for entry IEN in file FILENUM.
-        N CS,DIQOUT,IENROOT,MSG
-        D GETS^DIQ(FILENUM,IEN,"**","N","DIQOUT","MSG")
-        ;Remove edit history from all reminder files.
-        D RMEH^PXRMEXPU(FILENUM,.DIQOUT,1)
-        ;Convert the iens to the FDA adding form.
-        D CONTOFDA^PXRMEXPU(.DIQOUT,.IENROOT)
-        S CS=$$DIQOUTCS(.DIQOUT)
-        Q CS
-        ;
-        ;====================================================
-HFCS(PATH,FILENAME)     ;Return checksum for host file.
-        N CS,GBL,GBLZISH,SUCCESS
-        K ^TMP($J,"PXRMHFCS")
-        S GBL="^TMP($J,""PXRMHFCS"")"
-        S GBLZISH="^TMP($J,""PXRMHFCS"",1)"
-        S GBLZISH=$NA(@GBLZISH)
-        S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBLZISH,3)
-        S CS=$S(SUCCESS:$$HFCSGBL(GBL),1:-1)
-        K ^TMP($J,"PXRMHFCS")
-        Q CS
-        ;
-        ;====================================================
-HFCSGBL(GBL)    ;Return checksum for host file loaded into global GBL.
-        N CS,IND,LINE
-        S (CS,IND)=0
-        F  S IND=$O(@GBL@(IND)) Q:+IND=0  S LINE=@GBL@(IND),CS=$$CRC32^XLFCRC(LINE,CS)
-        Q CS
-        ;
-        ;====================================================
-MMCS(XMZ)       ;Return checksum for MailMan message ien XMZ.
-        N CS,IND,LINE,NLINES
-        S NLINES=+$P($G(^XMB(3.9,XMZ,2,0)),U,3)
-        S CS=0
-        F IND=1:1:NLINES S LINE=$G(^XMB(3.9,XMZ,2,IND,0)),CS=$$CRC32^XLFCRC(LINE,CS)
-        Q CS
-        ;
-        ;====================================================
-PFDACS(IEN,FDASTART,FDAEND)     ;Return checksum for FDA array of packed
-        ;reminder component.
-        N CS,DATA,IENS,IND,JND,FIELD,FNUM,SFN,TARGET,TEMP,TEXT
-        S TEMP=^PXD(811.8,IEN,100,FDASTART,0)
-        S FNUM=$P(TEMP,";",1)
-        D FIELD^DID(FNUM,"EDIT HISTORY","","SPECIFIER","TARGET")
-        S SFN=+$G(TARGET("SPECIFIER"))
-        S CS=0
-        F IND=FDASTART:1:FDAEND D
-        . S TEMP=^PXD(811.8,IEN,100,IND,0)
-        . S DATA=$P(TEMP,"~",2,99)
-        . S TEMP=$P(TEMP,"~",1)
-        . S FNUM=$P(TEMP,";",1)
-        . I FNUM=SFN Q
-        . I FNUM="Exchange Stub" Q
-        . S IENS=$P(TEMP,";",2)
-        . S FIELD=$P(TEMP,";",3)
-        . S TEXT=FNUM_$L(IENS,",")_FIELD_DATA
-        . S CS=$$CRC32^XLFCRC(TEXT,CS)
-        . I DATA["WP-start" F JND=1:1:$P(DATA,"~",2) D
-        .. S IND=IND+1
-        .. S TEXT=^PXD(811.8,IEN,100,IND,0)
-        .. S CS=$$CRC32^XLFCRC(TEXT,CS)
-        Q CS
-        ;
-        ;====================================================
-ROUTINE(RA)     ;Return checksum for a routine loaded in array RA. RA has the
-        ;form created by ^%ZOSF("LOAD") i.e, RA(1,0) ... RA(N,0).
-        N CS,IND,TEXT
-        S (CS,IND)=0
-        ;Get rid of the build number on the second line.
-        S RA(2,0)=$P(RA(2,0),";",1,6)
-        F  S IND=$O(RA(IND)) Q:+IND=0  D
-        . S TEXT=RA(IND,0)
-        . S CS=$$CRC32^XLFCRC(RA(IND,0),CS)
-        Q CS
-        ;
-        ;====================================================
-RTNCS(ROUTINE)  ;Return checksum for a routine ROUTINE.
-        N CS,DIF,RA,X,XCNP
-        S XCNP=0
-        S DIF="RA("
-        S X=ROUTINE
-        ;Make sure the routine exists.
-        X ^%ZOSF("TEST")
-        I $T D
-        . X ^%ZOSF("LOAD")
-        . S CS=$$ROUTINE(.RA)
-        E  S CS=-1
-        Q CS
-        ;
-        ;====================================================
-PRTNCS(IEN,START,END)   ;Return checksum for a packed routine.
-        N CS,IND,SL,TEXT
-        S CS=0,SL=START+1
-        F IND=START:1:END D
-        . S TEXT=^PXD(811.8,IEN,100,IND,0)
-        . ;Get rid of the build number on the second line.
-        . I IND=SL S TEXT=$P(TEXT,";",1,6)
-        . S CS=$$CRC32^XLFCRC(TEXT,CS)
-        Q CS
-        ;
+PXRMEXCS ; SLC/PKR - Routines to compute checksums. ;12/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;====================================================
+FILE(FILENUM,IEN) ;Return checksum for entry IEN in file FILENUM.
+ N CS,LC,REF,ROOT,TARGET
+ D FILE^DID(FILENUM,"","GLOBAL NAME","TARGET")
+ S ROOT=$$CREF^DILF(TARGET("GLOBAL NAME"))
+ K ^TMP($J,"PXRMEXCS")
+ M ^TMP($J,"PXRMEXCS")=@ROOT@(IEN)
+ S REF="^TMP($J,""PXRMEXCS"")"
+ S REF=$NA(@REF)
+ S (CS,LC)=0
+ F  S REF=$Q(@REF) Q:REF'["PXRMEXCS"  S LC=LC+1,CS=CS+$$LINECS(LC,@REF)
+ K ^TMP($J,"PXRMEXCS")
+ Q CS
+ ;
+ ;====================================================
+HFCS(PATH,FILENAME) ;Return checksum for host file.
+ N CS,GBL,GBLZISH,SUCCESS
+ K ^TMP($J,"PXRMHFCS")
+ S GBL="^TMP($J,""PXRMHFCS"")"
+ S GBLZISH="^TMP($J,""PXRMHFCS"",1)"
+ S GBLZISH=$NA(@GBLZISH)
+ S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBLZISH,3)
+ S CS=$S(SUCCESS:$$HFCSGBL(GBL),1:-1)
+ K ^TMP($J,"PXRMHFCS")
+ Q CS
+ ;
+ ;====================================================
+HFCSGBL(GBL) ;Return checksum for host file loaded into global GBL.
+ N CS,IND,LINE
+ S (CS,IND)=0
+ F  S IND=$O(@GBL@(IND)) Q:+IND=0  S LINE=@GBL@(IND),CS=CS+$$LINECS(IND,LINE)
+ Q CS
+ ;
+ ;====================================================
+LINECS(LINENUM,STRING) ;Return checksum of line number LINEUM whose contents
+ ;is STRING.
+ N CS,IND,LEN
+ S CS=0
+ S LEN=$L(STRING)
+ F IND=1:1:LEN S CS=CS+($A(STRING,IND)*(LINENUM+IND))
+ Q CS
+ ;
+ ;====================================================
+MMCS(XMZ) ;Return checksum for MailMan message ien XMZ.
+ N CS,IND,LINE,NLINES
+ S NLINES=+$P($G(^XMB(3.9,XMZ,2,0)),U,3)
+ S CS=0
+ F IND=1:1:NLINES S LINE=$G(^XMB(3.9,XMZ,2,IND,0)),CS=CS+$$LINECS(IND,LINE)
+ Q CS
+ ;
+ ;====================================================
+ROUTINE(RA) ;Return checksum for a routine loaded in array RA. RA has the
+ ;form created by ^%ZOSF("LOAD") i.e, RA(1,0) ... RA(N,0).
+ N CS,IND,LINE
+ S (CS,IND)=0
+ F  S IND=$O(RA(IND)) Q:+IND=0  S CS=CS+$$LINECS(IND,RA(IND,0))
+ Q CS
+ ;
+ ;====================================================
+RTN(ROUTINE) ;Return checksum for a routine ROUTINE.
+ N CS,DIF,RA,X,XCNP
+ S XCNP=0
+ S DIF="RA("
+ S X=ROUTINE
+ ;Make sure the routine exists.
+ X ^%ZOSF("TEST")
+ I $T D
+ . X ^%ZOSF("LOAD")
+ . S CS=$$ROUTINE(.RA)
+ E  S CS=-1
+ Q CS
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m

@@ -1 @@
-PXRMEXDG        ;SLC/PJH - Reminder Dialog Exchange index build ;05/16/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=====================================================================
-DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST,SPONLIST)   ;
-        ;
-        ;Routine to get dialog details for a given reminder
-        ;
-        ;Called as DIALOG^PXRMEXDG(RIEN,.DLIST,.FLIST)
-        ;
-        ;RIEN   - Reminder IEN
-        ;DLIST  - List of dialogs (components first)
-        ;FLIST  - Finding list used by PXRMEXPR
-        ;OLIST  - List of embedded TIU objects
-        ;TLIST  - List of embedded TIU templates
-        ;
-        ;Initialize
-        K DLIST
-        N DARRAY,DCNT,DIALOG,DIEN,FCNT,FINDING,OCNT,RCNT,RESULT,TEMP
-        ;Check if reminder exists
-        Q:'$D(^PXD(811.9,RIEN,0))
-        ;Get dialog ien from reminder definition
-        S DIEN=$P($G(^PXD(811.9,RIEN,51)),U) Q:'DIEN
-        ;Check dialog pointer is valid
-        Q:'$D(^PXRMD(801.41,DIEN))
-        ;Dialog and Finding count
-        S DCNT=0,FCNT=0,RCNT=0,TCNT=0
-        ;Get details
-        D GETSPON^PXRMEXPR(801.41,DIEN,.SPONLIST)
-        D DGET(DIEN,.SPONLIST)
-        ;
-        ;Now build the dialog list (components first)
-        S DCNT="",OCNT=0
-        F  S DCNT=$O(DARRAY(DCNT),-1) Q:'DCNT  D
-        .;Ignore dialogs previously encountered
-        .S DIEN=DARRAY(DCNT) Q:$D(DIALOG(DIEN))
-        .;Save dialog in output array
-        .S OCNT=OCNT+1,DIALOG(DIEN)="",TEMP("DIALOG",OCNT)=DIEN
-        ;
-        ;Save the dialog and result details to DLIST
-        N CNT,COUNT,DTYP
-        S COUNT=0
-        F DTYP="RESULT ELEMENT" D
-        .S CNT=0 F  S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0  D
-        ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
-        ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
-        ;
-        F DTYP="RESULT" D
-        .S CNT=0 F  S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0  D
-        ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
-        ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
-        ;
-        ;F DTYP="RESULT","DIALOG" D
-        F DTYP="DIALOG" D
-        .F CNT=1:1 S DIEN=$G(TEMP(DTYP,CNT)) Q:'DIEN  D
-        ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
-        ;
-        I COUNT>0 S DLIST("DIALOG")=801.41
-        ;
-        ;Add Dialog Findings to FLIST if not aready present
-        N DIC,DO,IEN,FNAME,FNUM,SUB
-        S SUB=0
-        F  S SUB=$O(TEMP("FINDING",SUB)) Q:'SUB  D
-        .S IEN=$P(TEMP("FINDING",SUB),";"),DIC=U_$P(TEMP("FINDING",SUB),";",2)
-        .K DO D DO^DIC1
-        .S FNUM=+DO(2),FNAME=$P(DO,U) I ('FNUM)!(FNAME="") Q
-        .;Check if present in FLIST
-        .I $D(FLIST(FNAME,"F",IEN)) Q
-        .;Otherwise add to list
-        .S:'$D(FLIST(FNAME)) FLIST(FNAME)=FNUM S FLIST(FNAME,"F",IEN)=""
-        .;Add the Health Factor category to FLIST
-        .I FNAME="HEALTH FACTORS" D
-        ..N HFCAT
-        ..S HFCAT=$P($G(^AUTTHF(IEN,0)),U,3) S:HFCAT FLIST(FNAME,"C",HFCAT)=""
-        ;
-        ;Store any TIU components
-        N GLOB,DIEN,CNT
-        ;Set global for search
-        S GLOB="^PXRMD(801.41,"
-        ;Search through all component dialogs
-        S CNT=0
-        F  S CNT=$O(DLIST("DIALOG",CNT)) Q:'CNT  D
-        .S DIEN=$O(DLIST("DIALOG",CNT,"")) Q:'DIEN
-        .;Search Dialog Text for TIU Objects and Templates
-        .D TIUSRCH(GLOB,DIEN,25,.OLIST,.TLIST)
-        .;Search P/N Text for TIU Objects and Templates
-        .D TIUSRCH(GLOB,DIEN,35,.OLIST,.TLIST)
-        ;
-        Q
-        ;
-        ;Get the dialog components
-        ;-------------------------
-DGET(D0,SPONLIST)       ;Save dialog ien
-        N D1
-        I $G(D0)=83
-        I $G(^PXRMD(801.41,D0,49))'="",$P(^PXRMD(801.41,D0,49),U,3)>0 D
-        .S D1=$P($G(^PXRMD(801.41,D0,49)),U,3) D DGET1(D0,.SPONLIST) D DGET1(D1,.SPONLIST)
-        E  D DGET1(D0,.SPONLIST)
-        Q
-DGET1(D0,SPONLIST)      ;
-        S DCNT=DCNT+1,DARRAY(DCNT)=D0
-        ;And details (except for reminder dialog)
-        I DCNT>1 D
-        .D GETSPON^PXRMEXPR(801.41,D0,.SPONLIST)
-        .;Finding items
-        .D DFIND(D0)
-        .;Additional Finding Items
-        .D DFINDA(D0)
-        .;Result groups
-        .D DRESULT(D0)
-        ;
-        ;Dialog components
-        N DCOMP,DCOMP1,DDATA,DSUB
-        S DSUB=0
-        F  S DSUB=$O(^PXRMD(801.41,D0,10,DSUB)) Q:'DSUB  D
-        .;Get any component dialogs
-        .S DCOMP=$P($G(^PXRMD(801.41,D0,10,DSUB,0)),U,2) Q:'DCOMP
-        .;If component exists get sub-components
-        .S DDATA=$G(^PXRMD(801.41,DCOMP,0)) Q:DDATA=""
-        .;Exclude national PXRM prompts
-        .I +$G(PXRMINST)=0,$E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q
-        .;Sub-components
-        .D DGET(DCOMP,.SPONLIST)
-        .;I $G(DCOMP1)'="" D DGET(DCOMP1) S DCOMP1=""
-        Q
-        ;
-        ;Build list of finding items
-        ;---------------------------
-DFIND(DIEN)     ;
-        N FIND,FIEN,FGLOB,FNAM
-        ;Finding Item
-        S FIND=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
-        ;If a finding item exists check and save
-LOOP    ;
-        I FIND]"" D
-        .;Finding item defined
-        .S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN  Q:FGLOB=""
-        .;And finding item exists
-        .Q:'$D(@(U_FGLOB_FIEN_",0)"))
-        .;Finding name
-        .S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???"
-        .;And not previously saved
-        .I '$D(FINDING(FIND)) D
-        ..S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND
-        I $G(^PXRMD(801.41,DIEN,49))'="",$P(^PXRMD(801.41,DIEN,49),U)>0 D
-        .S FIND=$P(^PXRMD(801.41,DIEN,49),U)
-        .I $D(FLIST("REMINDER TERM","F",FIND)) Q
-        .I '$D(FLIST("REMINDER TERM")) S FLIST("REMINDER TERM")="811.5"
-        .S FLIST("REMINDER TERM","F",FIND)=""
-        .D GETTFIND^PXRMEXPR(.FLIST)
-        Q
-        ;
-        ;Build list of additional findings
-        ;---------------------------------
-DFINDA(DIEN)    ;
-        N FIND,FIEN,FGLOB,FNAM,FSUB
-        S FSUB=0
-        F  S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB  D
-        .;Additional Finding Item
-        .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U)
-        .;If a finding item exists check and save
-        .I FIND]"" D
-        ..;Finding item defined
-        ..S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN  Q:FGLOB=""
-        ..;And finding item exists
-        ..Q:'$D(@(U_FGLOB_FIEN_",0)"))
-        ..;Finding name
-        ..S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???"
-        ..;And not previously saved
-        ..I '$D(FINDING(FIND)) D
-        ...S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND
-        Q
-        ;
-        ;Build list of result groups
-        ;---------------------------
-DRESULT(DIEN)   ;
-        N CNT,RIEN,RECNT,RGCNT
-        ;Result Group/Element pointer
-        S RECNT=$O(TEMP("RESULT ELEMENT",""),-1)
-        S RGCNT=$O(TEMP("RESULT",""),-1)
-        S CNT=0
-        F  S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0  D
-        .S RIEN=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) Q:RIEN'>0
-        .;S RIEN=$P($G(^PXRMD(801.41,DIEN,0)),U,15) Q:'RIEN  Q:$D(RESULT(RIEN))
-        .;Result group compoments
-        .N DSUB,REIEN
-        .S DSUB=0
-        .F  S DSUB=$O(^PXRMD(801.41,RIEN,10,DSUB)) Q:'DSUB  D
-        ..;Get result element
-        ..S REIEN=$P($G(^PXRMD(801.41,RIEN,10,DSUB,0)),U,2) Q:'REIEN
-        ..Q:'$D(^PXRMD(801.41,REIEN,0))
-        ..;If element exists get save it
-        ..S RECNT=RECNT+1,TEMP("RESULT ELEMENT",RECNT)=REIEN
-        ..;S RCNT=RCNT+1,OUTPUT("RESULT",RCNT)=REIEN
-        .;
-        .;Save result group
-        .S RGCNT=RGCNT+1,TEMP("RESULT",RGCNT)=RIEN
-        .;S RCNT=RCNT+1,RESULT(RIEN)="",TEMP("RESULT",RCNT)=RIEN
-        Q
-        ;
-        ;Extract TIU Objects/Templates from any WP text
-        ;----------------------------------------------
-TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST)      ;
-        N OCNT,TCNT,TEXT
-        ;Add to existing arrays
-        S OCNT=+$O(OLIST(""),-1),TCNT=+$O(TLIST(""),-1),SUB=0
-        ;Scan WP fields
-        F  S SUB=$O(@(GLOB_IEN_","_NODE_","_SUB_")")) Q:'SUB  D
-        .;Get individual line
-        .S TEXT=$G(@(GLOB_IEN_","_NODE_","_SUB_",0)")) Q:TEXT=""
-        .;Most text lines will have no TIU link so ignore them
-        .I (TEXT'["|")&(TEXT'["{FLD:") Q
-        .;Templates are in format {FLD:fldname} (only applies to dialogs)
-        .I GLOB[801.41 D TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT)
-        .;Objects are in format |Objectname|
-        .D TIUXTR("|","|",TEXT,.OLIST,.OCNT)
-        Q
-        ;
-TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT)      ;
-        N EXIST,IC,TXT,ONAME
-        S TXT=TEXT
-        F  D  Q:TXT'[SRCH
-        .S TXT=$E(TXT,$F(TXT,SRCH),$L(TXT)) Q:TXT'[SRCH1
-        .S ONAME=$P(TXT,SRCH1) Q:ONAME=""
-        .;Check if already selected
-        .S EXIST=0,IC=0
-        .F  S IC=$O(OUTPUT(IC)) Q:'IC  Q:EXIST  D
-        ..I $G(OUTPUT(IC))=ONAME S EXIST=1
-        .;Save array of object/template names
-        .I 'EXIST S CNT=CNT+1,OUTPUT(CNT)=ONAME
-        Q
+PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;02/25/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=====================================================================
+DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST) ;
+ ;
+ ;Routine to get dialog details for a given reminder
+ ;
+ ;Called as DIALOG^PXRMEXDG(RIEN,.DLIST,.FLIST)
+ ;
+ ;RIEN   - Reminder IEN
+ ;DLIST  - List of dialogs (components first)
+ ;FLIST  - Finding list used by PXRMEXPR
+ ;OLIST  - List of embedded TIU objects
+ ;TLIST  - List of embedded TIU templates
+ ;
+ ;Initialize
+ K DLIST
+ N DARRAY,DCNT,DIALOG,DIEN,FCNT,FINDING,OCNT,RCNT,RESULT,TEMP
+ ;Check if reminder exists
+ Q:'$D(^PXD(811.9,RIEN,0))
+ ;Get dialog ien from reminder definition
+ S DIEN=$P($G(^PXD(811.9,RIEN,51)),U) Q:'DIEN
+ ;Check dialog pointer is valid
+ Q:'$D(^PXRMD(801.41,DIEN))
+ ;Dialog and Finding count
+ S DCNT=0,FCNT=0,RCNT=0,TCNT=0
+ ;Get details
+ D DGET(DIEN)
+ ;
+ ;Now build the dialog list (components first)
+ S DCNT="",OCNT=0
+ F  S DCNT=$O(DARRAY(DCNT),-1) Q:'DCNT  D
+ .;Ignore dialogs previously encountered
+ .S DIEN=DARRAY(DCNT) Q:$D(DIALOG(DIEN))
+ .;Save dialog in output array
+ .S OCNT=OCNT+1,DIALOG(DIEN)="",TEMP("DIALOG",OCNT)=DIEN
+ ;
+ ;Save the dialog and result details to DLIST
+ N CNT,COUNT,DTYP
+ S COUNT=0
+ F DTYP="RESULT","DIALOG" D
+ .F CNT=1:1 S DIEN=$G(TEMP(DTYP,CNT)) Q:'DIEN  D
+ ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
+ ;
+ I COUNT>0 S DLIST("DIALOG")=801.41
+ ;
+ ;Add Dialog Findings to FLIST if not aready present
+ N DIC,DO,IEN,FNAME,FNUM,SUB
+ S SUB=0
+ F  S SUB=$O(TEMP("FINDING",SUB)) Q:'SUB  D
+ .S IEN=$P(TEMP("FINDING",SUB),";"),DIC=U_$P(TEMP("FINDING",SUB),";",2)
+ .K DO D DO^DIC1
+ .S FNUM=+DO(2),FNAME=$P(DO,U) I ('FNUM)!(FNAME="") Q
+ .;Check if present in FLIST
+ .I $D(FLIST(FNAME,"F",IEN)) Q
+ .;Otherwise add to list
+ .S:'$D(FLIST(FNAME)) FLIST(FNAME)=FNUM S FLIST(FNAME,"F",IEN)=""
+ .;Add the Health Factor category to FLIST
+ .I FNAME="HEALTH FACTORS" D
+ ..N HFCAT
+ ..S HFCAT=$P($G(^AUTTHF(IEN,0)),U,3) S:HFCAT FLIST(FNAME,"C",HFCAT)=""
+ ;
+ ;Store any TIU components
+ N GLOB,DIEN,CNT
+ ;Set global for search
+ S GLOB="^PXRMD(801.41,"
+ ;Search through all component dialogs
+ S CNT=0
+ F  S CNT=$O(DLIST("DIALOG",CNT)) Q:'CNT  D
+ .S DIEN=$O(DLIST("DIALOG",CNT,"")) Q:'DIEN
+ .;Search Dialog Text for TIU Objects and Templates
+ .D TIUSRCH(GLOB,DIEN,25,.OLIST,.TLIST)
+ .;Search P/N Text for TIU Objects and Templates
+ .D TIUSRCH(GLOB,DIEN,35,.OLIST,.TLIST)
+ ;
+ Q
+ ;
+ ;Get the dialog components
+ ;-------------------------
+DGET(D0) ;Save dialog ien
+ N D1
+ I $G(D0)=83
+ I $G(^PXRMD(801.41,D0,49))'="",$P(^PXRMD(801.41,D0,49),U,3)>0 D
+ .S D1=$P($G(^PXRMD(801.41,D0,49)),U,3) D DGET1(D0) D DGET1(D1)
+ E  D DGET1(D0)
+ Q
+DGET1(D0) ;
+ S DCNT=DCNT+1,DARRAY(DCNT)=D0
+ ;And details (except for reminder dialog)
+ I DCNT>1 D
+ .;Finding items
+ .D DFIND(D0)
+ .;Additional Finding Items
+ .D DFINDA(D0)
+ .;Result groups
+ .D DRESULT(D0)
+ ;
+ ;Dialog components
+ N DCOMP,DCOMP1,DDATA,DSUB
+ S DSUB=0
+ F  S DSUB=$O(^PXRMD(801.41,D0,10,DSUB)) Q:'DSUB  D
+ .;Get any component dialogs
+ .S DCOMP=$P($G(^PXRMD(801.41,D0,10,DSUB,0)),U,2) Q:'DCOMP
+ .;If component exists get sub-components
+ .S DDATA=$G(^PXRMD(801.41,DCOMP,0)) Q:DDATA=""
+ .;Exclude national PXRM prompts
+ .I $E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q
+ .;Sub-components
+ .D DGET(DCOMP)
+ .;I $G(DCOMP1)'="" D DGET(DCOMP1) S DCOMP1=""
+ Q
+ ;
+ ;Build list of finding items
+ ;---------------------------
+DFIND(DIEN) ;
+ N FIND,FIEN,FGLOB,FNAM
+ ;Finding Item
+ S FIND=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
+ ;If a finding item exists check and save
+LOOP ;
+ I FIND]"" D
+ .;Finding item defined
+ .S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN  Q:FGLOB=""
+ .;And finding item exists
+ .Q:'$D(@(U_FGLOB_FIEN_",0)"))
+ .;Finding name
+ .S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???"
+ .;And not previously saved
+ .I '$D(FINDING(FIND)) D
+ ..S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND
+ I $G(^PXRMD(801.41,DIEN,49))'="",$P(^PXRMD(801.41,DIEN,49),U)>0 D
+ .S FIND=$P(^PXRMD(801.41,DIEN,49),U)
+ .I $D(FLIST("REMINDER TERM","F",FIND)) Q
+ .I '$D(FLIST("REMINDER TERM")) S FLIST("REMINDER TERM")="811.5"
+ .S FLIST("REMINDER TERM","F",FIND)=""
+ .D GETTFIND^PXRMEXPR(.FLIST)
+ Q
+ ;
+ ;Build list of additional findings
+ ;---------------------------------
+DFINDA(DIEN) ;
+ N FIND,FIEN,FGLOB,FNAM,FSUB
+ S FSUB=0
+ F  S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB  D
+ .;Additional Finding Item
+ .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U)
+ .;If a finding item exists check and save
+ .I FIND]"" D
+ ..;Finding item defined
+ ..S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN  Q:FGLOB=""
+ ..;And finding item exists
+ ..Q:'$D(@(U_FGLOB_FIEN_",0)"))
+ ..;Finding name
+ ..S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???"
+ ..;And not previously saved
+ ..I '$D(FINDING(FIND)) D
+ ...S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND
+ Q
+ ;
+ ;Build list of result groups
+ ;---------------------------
+DRESULT(DIEN) ;
+ N RIEN
+ ;Result Group/Element pointer
+ S RIEN=$P($G(^PXRMD(801.41,DIEN,0)),U,15) Q:'RIEN  Q:$D(RESULT(RIEN))
+ ;Result group compoments
+ N DSUB,REIEN
+ S DSUB=0
+ F  S DSUB=$O(^PXRMD(801.41,RIEN,10,DSUB)) Q:'DSUB  D
+ .;Get result element
+ .S REIEN=$P($G(^PXRMD(801.41,RIEN,10,DSUB,0)),U,2) Q:'REIEN
+ .Q:'$D(^PXRMD(801.41,REIEN,0))
+ .;If element exists get save it
+ .S RCNT=RCNT+1,OUTPUT("RESULT",RCNT)=REIEN
+ ;
+ ;Save result group
+ S RCNT=RCNT+1,RESULT(RIEN)="",TEMP("RESULT",RCNT)=RIEN
+ Q
+ ;
+ ;Extract TIU Objects/Templates from any WP text
+ ;----------------------------------------------
+TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ;
+ N OCNT,TCNT,TEXT
+ ;Add to existing arrays
+ S OCNT=+$O(OLIST(""),-1),TCNT=+$O(TLIST(""),-1),SUB=0
+ ;Scan WP fields
+ F  S SUB=$O(@(GLOB_IEN_","_NODE_","_SUB_")")) Q:'SUB  D
+ .;Get individual line
+ .S TEXT=$G(@(GLOB_IEN_","_NODE_","_SUB_",0)")) Q:TEXT=""
+ .;Most text lines will have no TIU link so ignore them
+ .I (TEXT'["|")&(TEXT'["{FLD:") Q
+ .;Templates are in format {FLD:fldname} (only applies to dialogs)
+ .I GLOB[801.41 D TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT)
+ .;Objects are in format |Objectname|
+ .D TIUXTR("|","|",TEXT,.OLIST,.OCNT)
+ Q
+ ;
+TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT) ;
+ N EXIST,IC,TXT,ONAME
+ S TXT=TEXT
+ F  D  Q:TXT'[SRCH
+ .S TXT=$E(TXT,$F(TXT,SRCH),$L(TXT)) Q:TXT'[SRCH1
+ .S ONAME=$P(TXT,SRCH1) Q:ONAME=""
+ .;Check if already selected
+ .S EXIST=0,IC=0
+ .F  S IC=$O(OUTPUT(IC)) Q:'IC  Q:EXIST  D
+ ..I $G(OUTPUT(IC))=ONAME S EXIST=1
+ .;Save array of object/template names
+ .I 'EXIST S CNT=CNT+1,OUTPUT(CNT)=ONAME
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m

@@ -1 @@
-PXRMEXFI        ; SLC/PKR/PJH - Exchange utilities for file entries.;07/05/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;==============================================
-DELALL(FILENUM,NAME)    ;Delete all file entries named NAME.
-        N IEN,IND,LIST,MSG
-        D FIND^DIC(FILENUM,"","@","K",NAME,"*","","","","LIST","MSG")
-        I $P(LIST("DILIST",0),U,1)=0 Q
-        S IND=0
-        F  S IND=$O(LIST("DILIST",2,IND)) Q:IND=""  D
-        . S IEN=LIST("DILIST",2,IND)
-        . D DELETE(FILENUM,IEN)
-        Q
-        ;
-        ;==============================================
-DELETE(FILENUM,DA)      ;Delete a file entry.
-        N DIK
-        S DIK=$$ROOT^DILFD(FILENUM)
-        D ^DIK
-        Q
-        ;
-        ;==============================================
-FEIMSG(SAME,ATTR)       ;Output the general file exits install message.
-        N IND,NOUT,TEXT,TEXTO
-        S TEXT(1)=ATTR("FILE NAME")_" entry named "_ATTR("NAME")_" already exists"
-        I SAME D
-        . S TEXT(2)="and the packed component is identical, skipping."
-        . S TEXT(3)=" "
-        . D FORMAT^PXRMTEXT(1,70,3,.TEXT,.NOUT,.TEXTO)
-        . F IND=1:1:NOUT W !,TEXTO(IND)
-        . H 2
-        I 'SAME D
-        . S TEXT(2)="but the packed component is different, what do you want to do?"
-        . D FORMAT^PXRMTEXT(1,70,2,.TEXT,.NOUT,.TEXTO)
-        . F IND=1:1:NOUT W !,TEXTO(IND)
-        Q
-        ;
-        ;==============================================
-FOKTI(FILENUM)  ;Check if it is ok to install/transport this FILE.
-        ;
-        ;Drugs not allowed.
-        I FILENUM=50 Q 0
-        ;
-        ;VA Generic not allowed.
-        I FILENUM=50.6 Q 0
-        ;
-        ;VA Drug Class not allowed.
-        I FILENUM=50.605 Q 0
-        ;
-        ;Lab tests not allowed.
-        I FILENUM=60 Q 0
-        ;
-        ;Radiology procedures not allowed.
-        I FILENUM=71 Q 0
-        ;
-        ;ICD9 (used in Dialogs) not allowed.
-        I FILENUM=80 Q 0
-        ;
-        ;ICD0 not allowed.
-        I FILENUM=80.1 Q 0
-        ;
-        ;CPT (used in Dialogs) not allowed.
-        I FILENUM=81 Q 0
-        ;
-        ;Order Dialogs not allowed.
-        I FILENUM=101.41 Q 0
-        ;
-        ;Orderable Items not allowed.
-        I FILENUM=101.43 Q 0
-        ;
-        ;Sites cannot create entries in GMRV VITAL TYPE.
-        I FILENUM=120.51 Q 0
-        ;
-        ;Mental Health Instruments not allowed.
-        I FILENUM=601 Q 0
-        I FILENUM=601.71 Q 0
-        ;
-        I FILENUM=790.404 Q 0
-        ;
-        ;If control gets to here then it is an allowed file type.
-        Q 1
-        ;
-        ;==============================================
-GETFACT(PT01,ATTR,NEWPT01,NAMECHG,IEN)  ;Get the action for a file.
-        N ACTION,CHOICES,CSUM,DIR,FILENUM,MSG,RESULT
-        N SAME,X,Y
-        ;See if this entry is already defined.
-CHK     ;
-        S NEWPT01=""
-        S FILENUM=ATTR("FILE NUMBER")
-        I IEN="" S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
-        I IEN D
-        .;If the entry already exists compare the existing entry checksum
-        .;with the packed entry checksum.
-        . S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),IEN)
-        . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
-        . D FEIMSG(SAME,.ATTR)
-        . I SAME S ACTION="S"
-        . I 'SAME D
-        .. S CHOICES=$S(FILENUM=801.41:"CMOQS",FILENUM=811.5:"CMOQS",1:"COQS")
-        .. S DIR("B")="O"
-        .. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
-        E  D
-        . W !!,ATTR("FILE NAME")," entry ",PT01," is NEW,"
-        . W !,"what do you want to do?"
-        . S CHOICES="CIQS"
-        . S DIR("B")="I"
-        . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
-        ;
-        I ACTION="Q" Q ACTION
-        I ACTION="C" D
-        . S NEWPT01=$$GETUNAME^PXRMEXIU(.ATTR)
-        .;Make sure the NEW .01 passes any input transforms.
-        . I NEWPT01="" S ACTION="S"
-        . E  D CHK^DIE(ATTR("FILE NUMBER"),.01,"",NEWPT01,.RESULT,"MSG")
-        I $G(RESULT)="^" D  G CHK
-        . D AWRITE^PXRMUTIL("MSG")
-        . K RESULT
-        ;
-        I ACTION="O" D
-        .;If the action is overwrite double check that is what the user
-        .;really wants to do.
-        . N DIROUT,DIRUT,DTOUT,DUOUT
-        . K DIR
-        . S DIR(0)="Y"_U_"A"
-        . S DIR("A")="Are you sure you want to overwrite"
-        . S DIR("B")="N"
-        . D ^DIR
-        . I $D(DIROUT)!$D(DIRUT) S Y=0
-        . I $D(DTOUT)!$D(DUOUT) S Y=0
-        . S ACTION=$S(Y:"O",1:"S")
-        ;
-        I ACTION="P" D
-        . N DIC,Y
-        . S DIC=ATTR("FILE NUMBER")
-        . S DIC(0)="AEMQ"
-        . D ^DIC
-        . I Y=-1 S ACTION="S"
-        . E  S NEWPT01=$P(Y,U,2)
-        ;
-        I NEWPT01'="" S NAMECHG(ATTR("FILE NUMBER"),PT01)=NEWPT01
-        Q ACTION
-        ;
-        ;==============================================
-SETATTR(ATTR,FILE,PT01) ;Set the file attributes for the file FILE.
-        N MSG
-        S ATTR("FILE NUMBER")=FILE
-        S ATTR("FILE NAME")=$$GET1^DID(FILE,"","","NAME","","MSG")
-        ;This call gets the field length.
-        D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG")
-        S ATTR("MIN FIELD LENGTH")=3
-        S (ATTR("NAME"),ATTR("PT01"))=PT01
-        Q
-        ;
+PXRMEXFI ; SLC/PKR/PJH - Exchange utilities for file entries.;12/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;==============================================
+DELALL(FILENUM,NAME) ;Delete all file entries named NAME.
+ N IEN,IND,LIST,MSG
+ D FIND^DIC(FILENUM,"","@","K",NAME,"*","","","","LIST","MSG")
+ I $P(LIST("DILIST",0),U,1)=0 Q
+ S IND=0
+ F  S IND=$O(LIST("DILIST",2,IND)) Q:IND=""  D
+ . S IEN=LIST("DILIST",2,IND)
+ . D DELETE(FILENUM,IEN)
+ Q
+ ;
+ ;==============================================
+DELETE(FILENUM,DA) ;Delete a file entry.
+ N DIK
+ S DIK=$$ROOT^DILFD(FILENUM)
+ D ^DIK
+ Q
+ ;
+ ;==============================================
+FOKTI(FILENUM) ;Check if it is ok to install/transport this FILE.
+ ;
+ ;Drugs not allowed.
+ I FILENUM=50 Q 0
+ ;
+ ;VA Generic not allowed.
+ I FILENUM=50.6 Q 0
+ ;
+ ;VA Drug Class not allowed.
+ I FILENUM=50.605 Q 0
+ ;
+ ;Lab tests not allowed.
+ I FILENUM=60 Q 0
+ ;
+ ;Radiology procedures not allowed.
+ I FILENUM=71 Q 0
+ ;
+ ;ICD9 (used in Dialogs) not allowed.
+ I FILENUM=80 Q 0
+ ;
+ ;ICD0 not allowed.
+ I FILENUM=80.1 Q 0
+ ;
+ ;CPT (used in Dialogs) not allowed.
+ I FILENUM=81 Q 0
+ ;
+ ;Order Dialogs not allowed.
+ I FILENUM=101.41 Q 0
+ ;
+ ;Orderable Items not allowed.
+ I FILENUM=101.43 Q 0
+ ;
+ ;Sites cannot create entries in GMRV VITAL TYPE.
+ I FILENUM=120.51 Q 0
+ ;
+ ;Mental Health Instruments not allowed.
+ I FILENUM=601 Q 0
+ ;
+ I FILENUM=790.404 Q 0
+ ;
+ ;If control gets to here then it is an allowed file type.
+ Q 1
+ ;
+ ;==============================================
+GETFACT(PT01,ATTR,NEWPT01,NAMECHG,EXISTS) ;Get the action for a file.
+ N ACTION,CHOICES,DIR,FILENUM,MSG,RESULT,X,Y
+ ;See if this entry is already defined.
+CHK ;
+ S NEWPT01=""
+ S (ATTR("NAME"),ATTR("PT01"))=PT01
+ S FILENUM=ATTR("FILE NUMBER")
+ I EXISTS="" S EXISTS=$$EXISTS^PXRMEXIU(FILENUM,PT01)
+ ;Check for identical file entry can be made here.
+ I EXISTS D
+ . W !!,ATTR("FILE NAME")," entry ",PT01," already EXISTS,"
+ . W !,"what do you want to do?"
+ . S CHOICES=$S(FILENUM=801.41:"CMOQS",FILENUM=811.5:"CMOQS",1:"COQS")
+ . S DIR("B")="S"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ E  D
+ . W !!,ATTR("FILE NAME")," entry ",PT01," is NEW,"
+ . W !,"what do you want to do?"
+ . S CHOICES="CIQS"
+ . S DIR("B")="I"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ ;
+ I ACTION="Q" Q ACTION
+ I ACTION="C" D
+ . S NEWPT01=$$GETUNAME^PXRMEXIU(.ATTR)
+ .;Make sure the NEW .01 passes any input transforms.
+ . I NEWPT01="" S ACTION="S"
+ . E  D CHK^DIE(ATTR("FILE NUMBER"),.01,"",NEWPT01,.RESULT,"MSG")
+ I $G(RESULT)="^" D  G CHK
+ . D AWRITE^PXRMUTIL("MSG")
+ . K RESULT
+ ;
+ I ACTION="O" D
+ .;If the action is overwrite double check that is what the user
+ .;really wants to do.
+ . N DIROUT,DIRUT,DTOUT,DUOUT
+ . K DIR
+ . S DIR(0)="Y"_U_"A"
+ . S DIR("A")="Are you sure you want to overwrite"
+ . S DIR("B")="N"
+ . D ^DIR
+ . I $D(DIROUT)!$D(DIRUT) S Y=0
+ . I $D(DTOUT)!$D(DUOUT) S Y=0
+ . S ACTION=$S(Y:"O",1:"S")
+ ;
+ I ACTION="P" D
+ . N DIC,Y
+ . S DIC=ATTR("FILE NUMBER")
+ . S DIC(0)="AEMQ"
+ . D ^DIC
+ . I Y=-1 S ACTION="S"
+ . E  S NEWPT01=$P(Y,U,2)
+ ;
+ I NEWPT01'="" S NAMECHG(ATTR("FILE NUMBER"),PT01)=NEWPT01
+ Q ACTION
+ ;
+ ;==============================================
+SETATTR(ATTR,FILE) ;Set the file attributes for the file FILE.
+ N MSG
+ S ATTR("FILE NUMBER")=FILE
+ S ATTR("FILE NAME")=$$GET1^DID(FILE,"","","NAME","","MSG")
+ ;This call gets the field length.
+ D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG")
+ S ATTR("MIN FIELD LENGTH")=3
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m

@@ -1 @@
-PXRMEXID        ;SLC/PJH - Reminder Dialog Exchange Install Routine.;08/16/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;==================================================
-        ;
-        ;Install all dialog components in an exchange file entry
-        ;------------------------------------------------
-INSALL  N ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE
-        ;
-        ;Set the install date and time.
-        S IND="",PXRMDONE=0
-        ;
-        ;Go to full screen mode.
-        D FULL^VALM1
-        ;
-        ;Check if all or none exists - option to install all unchanged
-        N DNAME
-        S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
-        D EXIST^PXRMEXIX(.ALL,DNAME,"reminder dialog","")
-        I ALL=0 D DISP^PXRMEXLD(PXRMMODE) Q
-        ;
-        ;Lock the entire file
-        Q:'$$LOCK
-        F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(IND="")!(PXRMDONE)  D
-        .D INSCOM(IND,1)
-        ;
-        ;Clear lock
-        D UNLOCK
-        ;
-        ;Rebuild display workfile
-        D DISP^PXRMEXLD(PXRMMODE)
-        ;
-        K PXRMNMCH
-        Q
-        ;
-        ;Build list of descendents names
-        ;-------------------------------
-INSBLD(NAME,INAME)      ;
-        N DNAME,IDATA,ISEQ
-        S ISEQ=0
-        F  S ISEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:'ISEQ  D
-        .S IDATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:IDATA=""
-        .S DNAME=$P(IDATA,U) Q:DNAME=""
-        .;
-        .I $D(^TMP("PXRMEXTMP",$J,"DREPL"))>0 D
-        ..S REPL=$$CHKREPL^PXRMEXD1(NAME) I REPL>0 D INSREPL(NAME,REPL,.INAME)
-        .S INAME(DNAME)=""
-        .;Q:$$PXRM(DNAME)  S INAME(DNAME)=""
-        .;Check for descendants
-        .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
-        Q
-        ;Build list of replacement names
-        ;-------------------------------
-INSREPL(NAME,REPL,INAME)        ;
-        N DNAME,IDATA,ISEQ
-        S ISEQ=0
-        S IDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",REPL,NAME)) Q:IDATA=""
-        S DNAME=$P(IDATA,U) Q:DNAME=""  S INAME(DNAME)=""
-        ;S DNAME=$P(IDATA,U) Q:DNAME=""  Q:$$PXRM(DNAME)  S INAME(DNAME)=""
-        ;Check for descendants
-        I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
-        Q
-        ;
-        ;Install component IND
-        ;---------------------
-INSCOM(IND,SILENT)      ;
-        N ACTION,ATTR,CSUM,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
-        N NEWPT01,PT01,START,REPL,SAME,TEMP
-        S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),FILENUM=$P(TEMP,U,1)
-        S EXISTS=$P(TEMP,U,4),START=$P(TEMP,U,2),END=$P(TEMP,U,3) Q:START=""
-        S JND120=$P(TEMP,U,6) Q:'JND120
-        S IND120=$P(TEMP,U,5) Q:'IND120
-        S TEMP=^PXD(811.8,PXRMRIEN,100,START,0),PT01=$P(TEMP,"~",2) Q:PT01=""
-        S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",PT01))
-        I DTYP="dialog" S DTYP="reminder dialog"
-        ;
-        ;Go to full screen mode.
-        D FULL^VALM1
-        ;
-        ;Check for descendents
-        S REPL=$$CHKREPL^PXRMEXD1(PT01)
-        I 'SILENT&($$INSDSC(PT01)!(REPL>0)) D  Q:PXRMDONE
-        .N ANS,INDS,TEXT
-        .S TEXT(1)=PT01_" ("_DTYP_") contains sub-components."
-        .S TEXT="Install all sub-components with the "_DTYP_": "
-        .;Give option to install all descendents
-        .D ASK^PXRMEXIX(.ANS,.TEXT,1) Q:PXRMDONE
-        .I $G(ANS)="N" S PXRMDONE=1 Q
-        .I $G(ANS)="Y" D
-        ..S INDS=IND
-        ..N IDATA,INAME,IND
-        ..I REPL>0 D INSREPL(PT01,REPL,.INAME)
-        ..;Build list of decendents to install
-        ..D INSBLD(PT01,.INAME)
-        ..;Check if all or none exists - option to install all unchanged
-        ..D EXIST^PXRMEXIX(.ALL,PT01,DTYP,.INAME) Q:PXRMDONE
-        ..;Start at the end of the list
-        ..S IND=""
-        ..F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:PXRMDONE!(IND=INDS)  D
-        ...N PT01,START,TEMP
-        ...S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),START=$P(TEMP,U,2) Q:START=""
-        ...S PT01=$P(^PXD(811.8,PXRMRIEN,100,START,0),"~",2) Q:PT01=""
-        ...;Ignore namechanges
-        ...I $D(PXRMNMCH(801.41,PT01)) Q
-        ...;Only install descendents
-        ...I $D(INAME(PT01)) D INSCOM(IND,1)
-        ;
-SETENTRY        ;
-        D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
-        S ACTION=""
-        ;Double check that it hasn't been installed
-        S EXIEN=$$EXISTS^PXRMEXIU(801.41,PT01)
-        I EXIEN,'EXISTS S EXISTS=1
-        I EXISTS D
-        . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
-        . S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXIEN)
-        . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
-        . I SAME D FEIMSG^PXRMEXFI(SAME,.ATTR) S ACTION="S",(PXRMNMCH,NEWPT01)=""
-        I ACTION="" D
-        .;If all components installed the default is 'Install or Overwrite'
-        . S:ALL ACTION=$S(EXISTS:"O",1:"I"),(PXRMNMCH,NEWPT01)=""
-        . S:'ALL ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXIEN)
-        ;Save what was done for the installation summary.
-        S ^TMP("PXRMEXIAD",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
-        ;Clear heading
-        S VALMHDR(2)=""
-        ;If the ACTION is Quit then quit the entire install.
-        I ACTION="Q" S PXRMDONE=1 S VALMHDR(2)="Install not completed" Q
-        ;If the ACTION is Skip then skip this component.
-        I ACTION="S" S VALMBCK="R" Q
-        ;If the ACTION is Replace then skip this component.
-        I ACTION="P" S VALMBCK="R",VALMHDR(2)=PT01_" replaced with "_NEWPT01 Q
-        ;Install this component.
-        D FILE^PXRMEXIC(PXRMRIEN,EXIEN,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
-        S VALMBCK="R"
-        I PXRMDONE S VALMHDR(2)="Install aborted" Q
-        I NEWPT01="" S VALMHDR(2)=PT01_" ("_DTYP_") installed from exchange file."
-        I NEWPT01'="" S VALMHDR(2)=PT01_" installed as "_NEWPT01_"."
-        ;If reminder dialog - disable and give option to link
-        I DTYP="reminder dialog" D
-        .N DNAME
-        .S DNAME=PT01
-        .I NEWPT01'="" S DNAME=NEWPT01
-        .D INSLNK(DNAME)
-        Q
-        ;
-        ;Check for descendents (either elements or prompts)
-        ;--------------------------------------------------
-INSDSC(NAME)    ;
-        N DATA,DFOUND,SUB
-        S DFOUND=0,SUB=0
-        F  S SUB=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:'SUB  D  Q:DFOUND
-        .S DATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:DATA=""
-        .S DFOUND=1
-        .;I '$$PXRM($P(DATA,U)) S DFOUND=1
-        Q DFOUND
-        ;
-INSREPL1(NAME)  ;
-        N DATA,DFOUND,SUB
-        S DFOUND=0,SUB=0
-        F  S SUB=$O(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:'SUB  D  Q:DFOUND
-        .S DATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:DATA=""
-        .S DFOUND=1
-        Q DFOUND
-        ;Option to link dialog to a reminder
-        ;-----------------------------------
-INSLNK(DNAME)   ;
-        N DIEN,DISABLE,DSRC,RNAME
-        N DA,DIE,DR
-        ;Disable
-        S DIEN=$O(^PXRMD(801.41,"B",DNAME,"")) Q:'DIEN
-        ;Set dialog as disabled
-        S DISABLE="DISABLED IN EXCHANGE"
-        ;Except for National dialogs
-        I $P(^PXRMD(801.41,DIEN,100),U)="N" S DISABLE=""
-        ;
-        S DR="3///^S X=DISABLE",DIE="^PXRMD(801.41,",DA=$P(DIEN,U)
-        D ^DIE
-        ;
-        ;Quit if already linked
-        I $D(^PXD(811.9,"AG",DIEN)) Q
-        ;
-        S RNAME=""
-        ;If reminder was renamed use as default
-        I $D(PXRMNMCH(811.9)) D
-        .S RNAME=$O(PXRMNMCH(811.9,"")) Q:RNAME=""
-        .S RNAME=$G(PXRMNMCH(811.9,RNAME))
-        ;Otherwise use original reminder name as default
-        I RNAME="" D
-        .N DATA,FOUND,RIEN,SUB
-        .;Rebuild ^TMP("PXRMEXLC",$J
-        .D CDISP^PXRMEXLC(PXRMRIEN)
-        .;
-        .S SUB="",FOUND=0
-        .F  S SUB=$O(^TMP("PXRMEXLC",$J,"SEL",SUB),-1) Q:'SUB  Q:FOUND  D
-        ..S DATA=$G(^TMP("PXRMEXLC",$J,"SEL",SUB)) Q:$P(DATA,U)'=811.9
-        ..S RIEN=$P(DATA,U,4),FOUND=1 Q:'RIEN
-        ..S RNAME=$P($G(^PXD(811.9,RIEN,0)),U)
-        ;
-TAG     W !!,"Reminder Dialog "_DNAME_" is not linked to a reminder.",!
-        ;Select reminder to link
-        S IEN=$$SELECT^PXRMINQ("^PXD(811.9,","Select Reminder to Link: ",RNAME)
-        ;Update reminder link in #811.9
-        I $P(IEN,U)'=-1 D
-        .N DA,DIE,DIK,DR
-        .;Set reminder to dialog pointer
-        .S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=$P(IEN,U)
-        .D ^DIE
-        .;If source reminder is null replace with linked reminder
-        .S DSRC=$P($G(^PXRMD(801.41,DIEN,0)),U,2) Q:DSRC
-        .S DSRC=$P(IEN,U)
-        .S DR="2///^S X=DSRC",DIE="^PXRMD(801.41,",DA=$P(DIEN,U)
-        .D ^DIE
-        Q
-        ;
-        ;Install Selected Components
-        ;---------------------------
-INSSEL  N ALL,IND,PXRMDONE,VALMY
-        N DIROUT,DIRUT,DTOUT,DUOUT
-        N VALMBG,VALMLST
-        S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLD",$J,"IDX",""),-1)
-        ;Get the list to install.
-        D EN^VALM2(XQORNOD(0))
-        ;
-        ;Set the install date and time.
-        S ALL="",PXRMDONE=0
-        ;
-        ;Lock the entire file
-        Q:'$$LOCK
-        ;
-        S IND=0
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D INSCOM(IND,0)
-        ;
-        ;Clear locks
-        D UNLOCK
-        ;
-        ;Rebuild workfile
-        D DISP^PXRMEXLD(PXRMMODE)
-        Q
-        ;
-        ;Install the exchange entry PXRMRIEN
-        ;-----------------------------------
-INSTALL N IEN,IND,VALMY
-        ;Make sure the component list exists for this entry. PXRMRIEN is
-        ;set in INSTALL^PXRMEXLR.
-        I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN)
-        I PXRMRIEN=-1 Q
-        ;Format the component list for display.
-        D CDISP^PXRMEXLC(PXRMRIEN)
-        S VALMBCK="R",VALMCNT=$O(^TMP("PXRMEXLD",$J,"IDX"),-1)
-        Q
-        ;
-PXRM(NAME)      ;Validate prompts
-        ;
-        ;Ignore non-PXRM
-        I $E(NAME,1,4)'="PXRM" Q 0
-        N DIEN,RESULT
-        I $G(PXRMINST)=1 D  Q RESULT
-        .S RESULT=0
-        .S DIEN=$O(^PXRMD(801.41,"B",NAME,"")) I 'DIEN Q
-        .I $P($G(^PXRMD(801.41,DIEN,100)),U)'="N" Q
-        .I ($P($G(^PXRMD(801.41,DIEN,0)),U,4)="P")!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="F") S RESULT=1
-        ;
-        ;Check if this is a national code
-        S DIEN=$O(^PXRMD(801.41,"B",NAME,""))
-        ;If not found abort
-        I 'DIEN Q 0
-        ;if result group/element quit
-        I $P($G(^PXRMD(801.41,DIEN,0)),U,4)="S"!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="T") Q 0
-        ;Check class
-        I $P($G(^PXRMD(801.41,DIEN,100)),U)="N" Q 1
-        ;Otherwise local
-        Q 0
-        ;
-        ;Lock the dialog file
-LOCK()  ;
-        L +^PXRMD(801.41):0 I  Q 1
-        E  W !,"Another user is editing this file, try later" H 2
-        Q 0
-        ;
-        ;Clear lock
-UNLOCK  L -^PXRMD(801.41)
-        Q
+PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;11/14/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;==================================================
+ ;
+ ;Install all dialog components in an exchange file entry
+ ;------------------------------------------------
+INSALL N ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE
+ K ^TMP("PXRMEXIA",$J)
+ ;
+ ;Set the install date and time.
+ S IND="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
+ ;Go to full screen mode.
+ D FULL^VALM1
+ ;
+ ;Check if all or none exists - option to install all unchanged
+ N DNAME
+ S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
+ D EXIST^PXRMEXIX(.ALL,DNAME,"reminder dialog","")
+ ;
+ ;Lock the entire file
+ Q:'$$LOCK
+ ;
+ ;Install all components
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(+IND=0)!(PXRMDONE)  D
+ .D INSCOM(IND,1)
+ ;
+ ;Clear lock
+ D UNLOCK
+ ;
+ ;Rebuild display workfile
+ D DISP^PXRMEXLD(PXRMMODE)
+ ;
+ K PXRMNMCH
+ Q
+ ;
+ ;Build list of descendents names
+ ;-------------------------------
+INSBLD(NAME,INAME) ;
+ N DNAME,IDATA,ISEQ
+ S ISEQ=0
+ F  S ISEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:'ISEQ  D
+ .S IDATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:IDATA=""
+ .S DNAME=$P(IDATA,U) Q:DNAME=""  Q:$$PXRM(DNAME)  S INAME(DNAME)=""
+ .;Check for descendants
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
+ Q
+ ;
+ ;Install component IND
+ ;---------------------
+INSCOM(IND,SILENT) ;
+ N ACTION,ATTR,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
+ N NEWPT01,PT01,START,TEMP
+ S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),FILENUM=$P(TEMP,U,1)
+ S EXISTS=$P(TEMP,U,4),START=$P(TEMP,U,2),END=$P(TEMP,U,3) Q:START=""
+ S JND120=$P(TEMP,U,6) Q:'JND120
+ S IND120=$P(TEMP,U,5) Q:'IND120
+ S TEMP=^PXD(811.8,PXRMRIEN,100,START,0),PT01=$P(TEMP,"~",2) Q:PT01=""
+ S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",PT01))
+ I DTYP="dialog" S DTYP="reminder dialog"
+ ;
+ ;Go to full screen mode.
+ D FULL^VALM1
+ ;
+ ;Check for descendents
+ I 'SILENT,$$INSDSC(PT01) D  Q:PXRMDONE
+ .N ANS,INDS,TEXT
+ .S TEXT(1)=PT01_" ("_DTYP_") contains sub-components."
+ .S TEXT="Install all sub-components with the "_DTYP_": "
+ .;Give option to install all descendents
+ .D ASK^PXRMEXIX(.ANS,.TEXT,1) Q:PXRMDONE
+ .I $G(ANS)="Y" D
+ ..S INDS=IND
+ ..N IDATA,INAME,IND
+ ..;Build list of decendents to install
+ ..D INSBLD(PT01,.INAME)
+ ..;Check if all or none exists - option to install all unchanged
+ ..D EXIST^PXRMEXIX(.ALL,PT01,DTYP,.INAME) Q:PXRMDONE
+ ..;Start at the end of the list
+ ..S IND=""
+ ..F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:PXRMDONE!(IND=INDS)  D
+ ...N PT01,START,TEMP
+ ...S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),START=$P(TEMP,U,2) Q:START=""
+ ...S PT01=$P(^PXD(811.8,PXRMRIEN,100,START,0),"~",2) Q:PT01=""
+ ...;Ignore namechanges
+ ...I $D(PXRMNMCH(801.41,PT01)) Q
+ ...;Only install descendents
+ ...I $D(INAME(PT01)) D INSCOM(IND,1)
+ ;
+ D SETATTR^PXRMEXFI(.ATTR,FILENUM)
+ ;Double check that it hasn't been installed
+ S EXIEN=$$EXISTS^PXRMEXIU(801.41,PT01)
+ I EXIEN,'EXISTS S EXISTS=1
+ ;If all components installed the default is 'Install or Overwrite'
+ S:ALL ACTION=$S(EXISTS:"O",1:"I"),(ATTR("NAME"),ATTR("PT01"))=PT01,PXRMNMCH="",NEWPT01=""
+ S:'ALL ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS)
+ ;Save what was done for the installation summary.
+ S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
+ ;Clear heading
+ S VALMHDR(2)=""
+ ;If the ACTION is Quit then quit the entire install.
+ I ACTION="Q" S PXRMDONE=1 S VALMHDR(2)="Install not completed" Q
+ ;If the ACTION is Skip then skip this component.
+ I ACTION="S" S VALMBCK="R" Q
+ ;If the ACTION is Replace then skip this component.
+ I ACTION="P" S VALMBCK="R",VALMHDR(2)=PT01_" replaced with "_NEWPT01 Q
+ ;Install this component.
+ D FILE^PXRMEXIC(PXRMRIEN,EXIEN,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
+ S VALMBCK="R"
+ I PXRMDONE S VALMHDR(2)="Install aborted" Q
+ I NEWPT01="" S VALMHDR(2)=PT01_" ("_DTYP_") installed from exchange file."
+ I NEWPT01'="" S VALMHDR(2)=PT01_" installed as "_NEWPT01_"."
+ ;If reminder dialog - disable and give option to link
+ I DTYP="reminder dialog" D
+ .N DNAME
+ .S DNAME=PT01
+ .I NEWPT01'="" S DNAME=NEWPT01
+ .D INSLNK(DNAME)
+ Q
+ ;
+ ;Check for descendents (either elements or prompts)
+ ;--------------------------------------------------
+INSDSC(NAME) ;
+ N DATA,DFOUND,SUB
+ S DFOUND=0,SUB=0
+ F  S SUB=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:'SUB  D  Q:DFOUND
+ .S DATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:DATA=""
+ .I '$$PXRM($P(DATA,U)) S DFOUND=1
+ Q DFOUND
+ ;
+ ;Option to link dialog to a reminder
+ ;-----------------------------------
+INSLNK(DNAME) ;
+ N DIEN,DISABLE,DSRC,RNAME
+ N DA,DIE,DR
+ ;Disable
+ S DIEN=$O(^PXRMD(801.41,"B",DNAME,"")) Q:'DIEN
+ ;Set dialog as disabled
+ S DISABLE="DISABLED IN EXCHANGE"
+ ;Except for National dialogs
+ I $P(^PXRMD(801.41,DIEN,100),U)="N" S DISABLE=""
+ ;
+ S DR="3///^S X=DISABLE",DIE="^PXRMD(801.41,",DA=$P(DIEN,U)
+ D ^DIE
+ ;
+ ;Quit if already linked
+ I $D(^PXD(811.9,"AG",DIEN)) Q
+ ;
+ S RNAME=""
+ ;If reminder was renamed use as default
+ I $D(PXRMNMCH(811.9)) D
+ .S RNAME=$O(PXRMNMCH(811.9,"")) Q:RNAME=""
+ .S RNAME=$G(PXRMNMCH(811.9,RNAME))
+ ;Otherwise use original reminder name as default
+ I RNAME="" D
+ .N DATA,FOUND,RIEN,SUB
+ .;Rebuild ^TMP("PXRMEXLC",$J
+ .D CDISP^PXRMEXLC(PXRMRIEN)
+ .;
+ .S SUB="",FOUND=0
+ .F  S SUB=$O(^TMP("PXRMEXLC",$J,"SEL",SUB),-1) Q:'SUB  Q:FOUND  D
+ ..S DATA=$G(^TMP("PXRMEXLC",$J,"SEL",SUB)) Q:$P(DATA,U)'=811.9
+ ..S RIEN=$P(DATA,U,4),FOUND=1 Q:'RIEN
+ ..S RNAME=$P($G(^PXD(811.9,RIEN,0)),U)
+ ;
+TAG W !!,"Reminder Dialog "_DNAME_" is not linked to a reminder.",!
+ ;Select reminder to link
+ S IEN=$$SELECT^PXRMINQ("^PXD(811.9,","Select Reminder to Link: ",RNAME)
+ ;Update reminder link in #811.9
+ I $P(IEN,U)'=-1 D
+ .N DA,DIE,DIK,DR
+ .;Set reminder to dialog pointer
+ .S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=$P(IEN,U)
+ .D ^DIE
+ .;If source reminder is null replace with linked reminder
+ .S DSRC=$P($G(^PXRMD(801.41,DIEN,0)),U,2) Q:DSRC
+ .S DSRC=$P(IEN,U)
+ .S DR="2///^S X=DSRC",DIE="^PXRMD(801.41,",DA=$P(DIEN,U)
+ .D ^DIE
+ Q
+ ;
+ ;Install Selected Components
+ ;---------------------------
+INSSEL N ALL,IND,PXRMDONE,VALMY
+ N DIROUT,DIRUT,DTOUT,DUOUT
+ N VALMBG,VALMLST
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLD",$J,"IDX",""),-1)
+ ;Get the list to install.
+ D EN^VALM2(XQORNOD(0))
+ ;
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ALL="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
+ ;Lock the entire file
+ Q:'$$LOCK
+ ;
+ S IND=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .D INSCOM(IND,0)
+ ;
+ ;Clear locks
+ D UNLOCK
+ ;
+ ;Rebuild workfile
+ D DISP^PXRMEXLD(PXRMMODE)
+ Q
+ ;
+ ;Install the exchange entry PXRMRIEN
+ ;-----------------------------------
+INSTALL N IEN,IND,VALMY
+ ;Make sure the component list exists for this entry. PXRMRIEN is
+ ;set in INSTALL^PXRMEXLR.
+ I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN)
+ I PXRMRIEN=-1 Q
+ ;Format the component list for display.
+ D CDISP^PXRMEXLC(PXRMRIEN)
+ S VALMBCK="R",VALMCNT=$O(^TMP("PXRMEXLD",$J,"IDX"),-1)
+ Q
+ ;
+PXRM(NAME) ;Validate prompts
+ ;
+ ;Ignore non-PXRM
+ I $E(NAME,1,4)'="PXRM" Q 0
+ ;
+ ;Check if this is a national code
+ N DIEN
+ S DIEN=$O(^PXRMD(801.41,"B",NAME,""))
+ ;If not found abort
+ I 'DIEN Q 0
+ ;Check class
+ I $P($G(^PXRMD(801.41,DIEN,100)),U)="N" Q 1
+ ;Otherwise local
+ Q 0
+ ;
+ ;Lock the dialog file
+LOCK() ;
+ L +^PXRMD(801.41):0 I  Q 1
+ E  W !,"Another user is editing this file, try later" H 2
+ Q 0
+ ;
+ ;Clear lock
+UNLOCK L -^PXRMD(801.41)
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m

@@ -1 @@
-PXRMEXIU        ; SLC/PKR/PJH - Utilities for installing repository entries. ;07/27/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;===============================================
-DEF(FDA,NAMECHG)        ;Check the reminder definition to make sure the related
-        ;reminder exists and all the findings exist.
-        N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01
-        N RRG,SPONSOR,TEXT,VERSN
-        S IENS=$O(FDA(811.9,""))
-        ;
-        ;Related reminder guideline field 1.4.
-        I $D(FDA(811.9,IENS,1.4)) D
-        . S RRG=FDA(811.9,IENS,1.4)
-        . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG)
-        . I IEN=0 D
-        ..;Get replacement.
-        .. N DIC,X,Y
-        .. S TEXT(1)=" "
-        .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!"
-        .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty."
-        .. D MES^XPDUTL(.TEXT)
-        ..;If this is being called during a KIDS install we need echoing on.
-        .. I $D(XPDNM) X ^%ZOSF("EON")
-        .. S DIC=811.9,DIC(0)="AEMQ"
-        .. D ^DIC
-        .. I $D(XPDNM) X ^%ZOSF("EOFF")
-        .. I Y=-1 K FDA(811.9,IENS,1.4)
-        .. E  S FDA(811.9,IENS,1.4)=$P(Y,U,2)
-        ;
-        ;Sponsor field 101.
-        I $D(FDA(811.9,IENS,101)) D
-        . S SPONSOR=FDA(811.9,IENS,101)
-        . S IEN=$$FIND1^DIC(811.6,"","",SPONSOR)
-        . I IEN=0 D
-        ..;Get replacement.
-        .. N DIC,X,Y
-        .. S TEXT(1)=" "
-        .. S TEXT(2)="The Sponsor does not exist on your system!"
-        .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty."
-        .. D MES^XPDUTL(.TEXT)
-        ..;If this is being called during a KIDS install we need echoing on.
-        .. I $D(XPDNM) X ^%ZOSF("EON")
-        .. S DIC=811.6,DIC(0)="AEMQ"
-        .. D ^DIC
-        .. I $D(XPDNM) X ^%ZOSF("EOFF")
-        .. I Y=-1 K FDA(811.9,IENS,101)
-        .. E  S FDA(811.9,IENS,101)=$P(Y,U,2)
-        ;
-        ;Linked reminder dialog field 51.
-        S LRD=$G(FDA(811.9,IENS,51))
-        S IEN=$S(LRD="":0,1:+$O(^PXRMD(801.41,"B",LRD,"")))
-        I IEN=0 K FDA(811.9,IENS,51)
-        ;
-        ;Search the finding multiple for replacements and missing findings.
-        D BLDALIST^PXRMVPTR(811.902,.01,.ALIST)
-        S IENS=""
-        F  S IENS=$O(FDA(811.902,IENS)) Q:IENS=""  D
-        . S (FINDING,OFINDING)=FDA(811.902,IENS,.01)
-        . S ABBR=$P(FINDING,".",1)
-        . S PT01=$P(FINDING,".",2)
-        . S FILENUM=$P(ALIST(ABBR),U,1)
-        . I $D(NAMECHG(FILENUM,PT01)) D
-        .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
-        .. S FDA(811.902,IENS,.01)=FINDING
-        . S IEN=+$$VFIND1(FINDING,.ALIST)
-        . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN
-        . I IEN=0 D
-        ..;Get replacement
-        .. N DIC,DUOUT,TEXT,X,Y
-        .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
-        .. W !,TEXT
-        .. S DIC=FILENUM
-        .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
-        .. S DIC(0)="AEMNQ"
-        .. S Y=-1
-        .. F  Q:+Y'=-1  D
-        ...;If this is being called during a KIDS install we need echoing on.
-        ... I $D(XPDNM) X ^%ZOSF("EON")
-        ... D ^DIC
-        ... I $D(XPDNM) X ^%ZOSF("EOFF")
-        ... I $D(DUOUT) S Y="" K FDA
-        .. I Y="" Q
-        .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING
-        .;Save the finding information for the history.
-        . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING
-        .;Save changes to Orderable items for dialog
-        . I FILENUM=101.43,OFINDING'=FINDING
-        . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2)
-        S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
-        I VERSN=1.5 D CEFD^PXRMDATE(.FDA)
-        Q
-        ;
-        ;===============================================
-EXISTS(FILENUM,NAME,FLAG)       ;Check for existence of an entry with the
-        ;same name. Return 0 for null name
-        I NAME="" Q 0
-        ;Return the ien if it does, 0 otherwise.
-        N IEN
-        I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q
-        N FLAGS,RESULT
-        S RESULT=NAME
-        ;Special lookup for files 80 and 80.1, they do not have a standard "B"
-        ;cross-reference.
-        I (FILENUM=80)!(FILENUM=80.1) D
-        .;Name may or may not have the necessary space appended, make sure
-        .;it does.
-        . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME)
-        . S FLAGS="MX"
-        E  S FLAGS="BX"
-        I FILENUM=811.6 S FLAGS=FLAGS_"U"
-        ;File 8927.1 only allows upper case .01s.
-        I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME)
-        S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT)
-        I +IEN>0 Q IEN
-        ;If IEN is null then there was an error try FIND^DIC.
-        N FILENAME,LIST,MSG,NFOUND,TEXT
-        D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG")
-        S NFOUND=+$P(LIST("DILIST",0),U,1)
-        I NFOUND=0 Q 0
-        I NFOUND=1 Q LIST("DILIST",2,1)
-        ;Multiple entries with the same name found.
-        S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
-        S TEXT(1)="Warning there are "_NFOUND_" "_FILENAME_" entries with the name "_NAME_"!"
-        S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during"
-        S TEXT(3)="installation, any component using this finding will not install."
-        D EN^DDIOL(.TEXT)
-        I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1)
-        I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.LIST)
-        Q IEN
-        ;
-        ;===============================================
-GETACT(CHOICES,DIR)     ;Get the action
-        ;If CHOICES is empty the only action is skip.
-        I CHOICES="" Q "S"
-        N DIROUT,DIRUT,DTOUT,DUOUT,X,Y
-        S DIR(0)="S"_U
-        I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name"
-        I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete (from the reminder/dialog)"
-        I CHOICES["I" S DIR(0)=DIR(0)_";I:Install"
-        I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings"
-        I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry"
-        I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace (in the reminder/dialog) with an existing entry"
-        I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install"
-        I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart"
-        I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry"
-        ;If this is being called during a KIDS install we need echoing on.
-        I $D(XPDNM) X ^%ZOSF("EON")
-        D ^DIR
-        I $D(XPDNM) X ^%ZOSF("EOFF")
-        I $D(DIROUT)!$D(DIRUT) S Y="S"
-        I $D(DTOUT)!($D(DUOUT)) S Y="S"
-        Q Y
-        ;
-        ;===============================================
-GETNAME(MIN,MAX)        ;Get a name to use.
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
-        S DIR(0)="FAOU"_U_MIN_":"_MAX
-        S DIR("A")="Input the new name: "
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q ""
-        I $D(DTOUT)!$D(DUOUT) Q ""
-        Q Y
-        ;
-        ;===============================================
-GETUNAME(ATTR)  ;Get a unique name to use, ATTR holds the attributes.
-        N IEN,NEWPT01,TEXT
-GNEW    S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
-        S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01)
-        I IEN>0 D  G GNEW
-        . S TEXT=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?"
-        . D EN^DDIOL(TEXT)
-        E  S ATTR("NAME")=NEWPT01
-        Q NEWPT01
-        ;
-        ;===============================================
-HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not
-        ;have a category.
-        N IENS
-        S IENS=$O(FDA(9999999.64,""))
-        I IENS="" Q
-        I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03)
-        Q
-        ;
-        ;===============================================
-LABPANEL(IEN)   ;
-        N NODE
-        S NODE=^LAB(60,IEN,0)
-        I $P(NODE,U,4)'["CH" Q 1
-        I $P(NODE,U,5)="" Q 0
-        Q 1
-        ;
-        ;===============================================
-REXISTS(NAME,DATEP)     ;See if this Exchange File entry already exists.
-        N IEN,LUVALUE
-        S LUVALUE(1)=NAME
-        S LUVALUE(2)=DATEP
-        S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
-        Q IEN
-        ;
-        ;===============================================
-TERM(FDA,NAMECHG)       ;Check the reminder term to make sure all the
-        ;findings exist.
-        N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01
-        ;Search the finding multiple for replacements and missing findings.
-        D BLDALIST^PXRMVPTR(811.52,.01,.ALIST)
-        S IENS=""
-        F  S IENS=$O(FDA(811.52,IENS)) Q:IENS=""  D
-        . S (FINDING,OFINDING)=FDA(811.52,IENS,.01)
-        . S ABBR=$P(FINDING,".",1)
-        . S PT01=$P(FINDING,".",2)
-        . S FILENUM=$P(ALIST(ABBR),U,1)
-        . I $D(NAMECHG(FILENUM,PT01)) D
-        .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
-        .. S FDA(811.52,IENS,.01)=FINDING
-        . S IEN=+$$VFIND1(FINDING,.ALIST)
-        . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN
-        . I IEN=0 D
-        ..;Get replacement
-        .. N DIC,DUOUT,TEXT,X,Y
-        .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
-        .. D BMES^XPDUTL(TEXT)
-        .. S DIC=FILENUM
-        .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
-        .. S DIC(0)="AEMNQ"
-        .. S Y=-1
-        .. F  Q:+Y'=-1  D
-        ...;If this is being called during a KIDS install we need echoing on.
-        ... I $D(XPDNM) X ^%ZOSF("EON")
-        ... D ^DIC
-        ... I $D(XPDNM) X ^%ZOSF("EOFF")
-        ... I $D(DUOUT) D
-        .... S Y=""
-        .... K FDA
-        .. I Y="" K FDA(811.52,IENS)
-        .. E  D
-        ... S FINDING=ABBR_"."_$P(Y,U,2)
-        ... S FDA(811.52,IENS,.01)=FINDING
-        .;Save the finding information for the history.
-        . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING
-        Q
-        ;
-        ;===============================================
-VFIND1(VPTR,ALIST)      ;Given a variable pointer of the form ABBR.NAME
-        ;and ALIST which contains the link between abbreviations and files
-        ;return the IEN if it exists and 0 if no match if found.
-        N ABBR,IEN,FILENUM,PT01,RESULT
-        S IEN=0
-        S ABBR=$P(VPTR,".",1)
-        S PT01=$P(VPTR,".",2,99)
-        S FILENUM=$P(ALIST(ABBR),U,1)
-        S IEN=$$EXISTS(FILENUM,PT01)
-        Q IEN
-        ;
+PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;06/23/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;===============================================
+DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related
+ ;reminder exists and all the findings exist.
+ N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01
+ N RRG,SPONSOR,TEXT,VERSN
+ S IENS=$O(FDA(811.9,""))
+ ;
+ ;Related reminder guideline field 1.4.
+ I $D(FDA(811.9,IENS,1.4)) D
+ . S RRG=FDA(811.9,IENS,1.4)
+ . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG)
+ . I IEN=0 D
+ ..;Get replacement.
+ .. N DIC,X,Y
+ .. S TEXT(1)=" "
+ .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!"
+ .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty."
+ .. D MES^XPDUTL(.TEXT)
+ ..;If this is being called during a KIDS install we need echoing on.
+ .. I $D(XPDNM) X ^%ZOSF("EON")
+ .. S DIC=811.9,DIC(0)="AEMQ"
+ .. D ^DIC
+ .. I $D(XPDNM) X ^%ZOSF("EOFF")
+ .. I Y=-1 K FDA(811.9,IENS,1.4)
+ .. E  S FDA(811.9,IENS,1.4)=$P(Y,U,2)
+ ;
+ ;Sponsor field 101.
+ I $D(FDA(811.9,IENS,101)) D
+ . S SPONSOR=FDA(811.9,IENS,101)
+ . S IEN=$$FIND1^DIC(811.6,"","",SPONSOR)
+ . I IEN=0 D
+ ..;Get replacement.
+ .. N DIC,X,Y
+ .. S TEXT(1)=" "
+ .. S TEXT(2)="The Sponsor does not exist on your system!"
+ .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty."
+ .. D MES^XPDUTL(.TEXT)
+ ..;If this is being called during a KIDS install we need echoing on.
+ .. I $D(XPDNM) X ^%ZOSF("EON")
+ .. S DIC=811.6,DIC(0)="AEMQ"
+ .. D ^DIC
+ .. I $D(XPDNM) X ^%ZOSF("EOFF")
+ .. I Y=-1 K FDA(811.9,IENS,101)
+ .. E  S FDA(811.9,IENS,101)=$P(Y,U,2)
+ ;
+ ;Linked reminder dialog field 51.
+ S LRD=+$G(FDA(811.9,IENS,51))
+ S IEN=$$EXISTS^PXRMEXIU(801.41,LRD)
+ I IEN=0 K FDA(811.9,IENS,51)
+ ;
+ ;Search the finding multiple for replacements and missing findings.
+ D BLDALIST^PXRMVPTR(811.902,.01,.ALIST)
+ S IENS=""
+ F  S IENS=$O(FDA(811.902,IENS)) Q:IENS=""  D
+ . S (FINDING,OFINDING)=FDA(811.902,IENS,.01)
+ . S ABBR=$P(FINDING,".",1)
+ . S PT01=$P(FINDING,".",2)
+ . S FILENUM=$P(ALIST(ABBR),U,1)
+ . I $D(NAMECHG(FILENUM,PT01)) D
+ .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+ .. S FDA(811.902,IENS,.01)=FINDING
+ . S IEN=+$$VFIND1(FINDING,.ALIST)
+ . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN
+ . I IEN=0 D
+ ..;Get replacement
+ .. N DIC,DUOUT,TEXT,X,Y
+ .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
+ .. W !,TEXT
+ .. S DIC=FILENUM
+ .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
+ .. S DIC(0)="AEMNQ"
+ .. S Y=-1
+ .. F  Q:+Y'=-1  D
+ ...;If this is being called during a KIDS install we need echoing on.
+ ... I $D(XPDNM) X ^%ZOSF("EON")
+ ... D ^DIC
+ ... I $D(XPDNM) X ^%ZOSF("EOFF")
+ ... I $D(DUOUT) S Y="" K FDA
+ .. I Y="" Q
+ .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING
+ .;Save the finding information for the history.
+ . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING
+ .;Save changes to Orderable items for dialog
+ . I FILENUM=101.43,OFINDING'=FINDING
+ . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2)
+ S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
+ I VERSN=1.5 D CEFD^PXRMDATE(.FDA)
+ Q
+ ;
+ ;===============================================
+EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the
+ ;same name. Return 0 for null name
+ I NAME="" Q 0
+ ;Return the ien if it does, 0 otherwise.
+ N IEN
+ I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q
+ N FLAGS,RESULT
+ S RESULT=NAME
+ ;Special lookup for files 80 and 80.1, they do not have a standard "B"
+ ;cross-reference.
+ I (FILENUM=80)!(FILENUM=80.1) D
+ .;Name may or may not have the necessary space appended, make sure
+ .;it does.
+ . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME)
+ . S FLAGS="MX"
+ E  S FLAGS="BX"
+ I FILENUM=811.6 S FLAGS=FLAGS_"U"
+ ;File 8927.1 only allows upper case .01s.
+ I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME)
+ S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT)
+ I +IEN>0 Q IEN
+ ;If IEN is null then there was an error try FIND^DIC.
+ N FILENAME,LIST,MSG,NFOUND,TEXT
+ D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG")
+ S NFOUND=+$P(LIST("DILIST",0),U,1)
+ I NFOUND=0 Q 0
+ I NFOUND=1 Q LIST("DILIST",2,1)
+ ;Multiple entries with the same name found.
+ S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
+ S TEXT(1)="Warning there are "_NFOUND_" "_FILENAME_" entries with the name "_NAME_"!"
+ S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during"
+ S TEXT(3)="installation, any component using this finding will not install."
+ D EN^DDIOL(.TEXT)
+ I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1)
+ I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.LIST)
+ Q IEN
+ ;
+ ;===============================================
+GETACT(CHOICES,DIR) ;Get the action
+ ;If CHOICES is empty the only action is skip.
+ I CHOICES="" Q "S"
+ N DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S DIR(0)="S"_U
+ I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name"
+ I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete (from the reminder/dialog)"
+ I CHOICES["I" S DIR(0)=DIR(0)_";I:Install"
+ I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings"
+ I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry"
+ I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace (in the reminder/dialog) with an existing entry"
+ I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install"
+ I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart"
+ I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry"
+ ;If this is being called during a KIDS install we need echoing on.
+ I $D(XPDNM) X ^%ZOSF("EON")
+ D ^DIR
+ I $D(XPDNM) X ^%ZOSF("EOFF")
+ I $D(DIROUT)!$D(DIRUT) S Y="S"
+ I $D(DTOUT)!($D(DUOUT)) S Y="S"
+ Q Y
+ ;
+ ;===============================================
+GETNAME(MIN,MAX) ;Get a name to use.
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S DIR(0)="FAOU"_U_MIN_":"_MAX
+ S DIR("A")="Input the new name: "
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q ""
+ I $D(DTOUT)!$D(DUOUT) Q ""
+ Q Y
+ ;
+ ;===============================================
+GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes.
+ N IEN,NEWPT01,TEXT
+GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
+ S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01)
+ I IEN>0 D  G GNEW
+ . S TEXT=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?"
+ . D EN^DDIOL(TEXT)
+ E  S ATTR("NAME")=NEWPT01
+ Q NEWPT01
+ ;
+ ;===============================================
+HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not
+ ;have a category.
+ N IENS
+ S IENS=$O(FDA(9999999.64,""))
+ I IENS="" Q
+ I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03)
+ Q
+ ;
+ ;===============================================
+LABPANEL(IEN) ;
+ N NODE
+ S NODE=^LAB(60,IEN,0)
+ I $P(NODE,U,4)'["CH" Q 1
+ I $P(NODE,U,5)="" Q 0
+ Q 1
+ ;
+ ;===============================================
+REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists.
+ N IEN,LUVALUE
+ S LUVALUE(1)=NAME
+ S LUVALUE(2)=DATEP
+ S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+ Q IEN
+ ;
+ ;===============================================
+SAME(ATTR,TA,NAME) ;Check existing entry and entry in packed reminder
+ ;definition to see if they are identical.
+ ;Present version only works for computed finding routines, other
+ ;types of entries can be added later.
+ N SAME
+ I ATTR("FILE NAME")="COMPUTED FINDING ROUTINE" S SAME=$$SAME^PXRMEXCF(.ATTR,.TA,NAME)
+ E  S SAME=1
+ Q SAME
+ ;
+ ;===============================================
+TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the
+ ;findings exist.
+ N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01
+ ;Search the finding multiple for replacements and missing findings.
+ D BLDALIST^PXRMVPTR(811.52,.01,.ALIST)
+ S IENS=""
+ F  S IENS=$O(FDA(811.52,IENS)) Q:IENS=""  D
+ . S (FINDING,OFINDING)=FDA(811.52,IENS,.01)
+ . S ABBR=$P(FINDING,".",1)
+ . S PT01=$P(FINDING,".",2)
+ . S FILENUM=$P(ALIST(ABBR),U,1)
+ . I $D(NAMECHG(FILENUM,PT01)) D
+ .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+ .. S FDA(811.52,IENS,.01)=FINDING
+ . S IEN=+$$VFIND1(FINDING,.ALIST)
+ . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN
+ . I IEN=0 D
+ ..;Get replacement
+ .. N DIC,DUOUT,TEXT,X,Y
+ .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
+ .. D BMES^XPDUTL(TEXT)
+ .. S DIC=FILENUM
+ .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
+ .. S DIC(0)="AEMNQ"
+ .. S Y=-1
+ .. F  Q:+Y'=-1  D
+ ...;If this is being called during a KIDS install we need echoing on.
+ ... I $D(XPDNM) X ^%ZOSF("EON")
+ ... D ^DIC
+ ... I $D(XPDNM) X ^%ZOSF("EOFF")
+ ... I $D(DUOUT) D
+ .... S Y=""
+ .... K FDA
+ .. I Y="" K FDA(811.52,IENS)
+ .. E  D
+ ... S FINDING=ABBR_"."_$P(Y,U,2)
+ ... S FDA(811.52,IENS,.01)=FINDING
+ .;Save the finding information for the history.
+ . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING
+ Q
+ ;
+ ;===============================================
+VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME
+ ;and ALIST which contains the link between abbreviations and files
+ ;return the IEN if it exists and 0 if no match if found.
+ N ABBR,IEN,FILENUM,PT01,RESULT
+ S IEN=0
+ S ABBR=$P(VPTR,".",1)
+ S PT01=$P(VPTR,".",2,99)
+ S FILENUM=$P(ALIST(ABBR),U,1)
+ S IEN=$$EXISTS(FILENUM,PT01)
+ Q IEN
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m

@@ -1 @@
-PXRMEXIX        ;SLC/PJH - Reminder Dialog Exchange checks. ;10/10/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=====================================================================
-        ;
-        ;Yes/No Prompts
-        ;--------------
-ASK(YESNO,TEXT,HELP)    ;
-        W !
-        N DIR,X,Y
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="YA0"
-        M DIR("A")=TEXT
-        S DIR("B")="Y"
-        S DIR("?")="Enter Y or N. For detailed help type ??"
-        S DIR("??")=U_"D HLP^PXRMEXIX(HELP)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) S PXRMDONE=1 Q
-        S YESNO=$E(Y(0))
-        Q
-        ;
-        ;Dialog check - all exist, none exist or some exist
-        ;--------------------------------------------------
-EXIST(ALL,DNAME,DTYP,INAME)     ;
-        ;0 - None exist
-        ;1 - All exist
-        ;2 - Some exist
-        ;
-        ;Look for component dialogs in DMAP node from PXRMEXIC
-        N DONE,DOTHER,EXISTS,FILE,MODE
-        S ALL="",DONE=0,MODE="",NAME=""
-        ;
-        I DTYP="reminder dialog" D
-        .F  S NAME=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME)) Q:NAME=""  D  Q:DONE
-        ..;Check if dialog exists
-        ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME)
-        ..;If exists accumulate list of ancestors
-        ..I EXISTS D OTHER(NAME,.DOTHER)
-        ..;Quit if some exist and some don't
-        ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q
-        ..I MODE=0,EXISTS S MODE=2,DONE=1 Q
-        ..;Set all exists flag if dialog found
-        ..I MODE="",EXISTS S MODE=1
-        ..;Set none exists flag if dialog not found
-        ..I MODE="",'EXISTS S MODE=0
-        ;
-        I DTYP'="reminder dialog" D
-        .F  S NAME=$O(INAME(NAME)) Q:NAME=""  D  Q:DONE
-        ..;Treat namechanges as 'done'
-        ..I $D(PXRMNMCH(801.41,NAME)) Q
-        ..;Check if dialog exists
-        ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME)
-        ..;If exists accumulate list of ancestors
-        ..I EXISTS D OTHER(NAME,.DOTHER)
-        ..;Quit if some exist and some don't
-        ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q
-        ..I MODE=0,EXISTS S MODE=2,DONE=1 Q
-        ..;Set all exists flag if dialog found
-        ..I MODE="",EXISTS S MODE=1
-        ..;Set none exists flag if dialog not found
-        ..I MODE="",'EXISTS S MODE=0
-        ;
-        ;If all or none exist give option to install all without prompting
-        N ANS,TEXT
-        I MODE=0 D 
-        .S TEXT(1)="All dialog components for "_DNAME_" are new."
-        I MODE=1 D
-        .S TEXT(1)="All dialog components for "_DNAME_" already exist."
-        .S TEXT(2)="",TEXT(4)=""
-        .S TEXT(3)="Components not used by any other dialogs."
-        .;Warn if used by other dialogs
-        .I $D(DOTHER) D
-        ..S TEXT(3)="WARNING - some components already used by:"
-        ..N CNT,DLIT,DNAME,DTYP,FIRST,NAME
-        ..S CNT=4,DNAME="",TEXT(CNT)=""
-        ..F  S DNAME=$O(DOTHER(DNAME)) Q:DNAME=""  D
-        ...S NAME="",FIRST=1,CNT=CNT+1
-        ...S DTYP=DOTHER(DNAME)
-        ...I DTYP="R" S DTYP="Reminder Dialog"
-        ...I DTYP="G" S DTYP="Dialog Group"
-        ...I DTYP="E" S DTYP="Dialog Element"
-        ...;S CNT=CNT+1,FIRST=0,TEXT(CNT)=DLIT_NAME_" ("_DTYP_")"
-        ...S CNT=CNT+1,FIRST=0,TEXT(CNT)=DNAME_" ("_DTYP_")"
-        ..S CNT=CNT+1,TEXT(CNT)=""
-        S TEXT="Install "_DTYP_" and all components with no further changes: "
-        ;Give option to install all descendents
-        D ASK(.ANS,.TEXT,2) I $G(ANS)="Y" S ALL=1
-        I $G(ANS)="N" S ALL=0
-        Q
-        ;
-        ;Check if used by other dialogs
-        ;------------------------------
-OTHER(NAME,LIST)        ;
-        N DDATA,DIEN,DNAME,DTYP,IEN
-        S IEN=$O(^PXRMD(801.41,"B",NAME,0)) Q:'IEN
-        ;Check if used by other dialogs
-        I '$D(^PXRMD(801.41,"AD",IEN)) Q
-        ;Build list of dialogs using this component
-        S DIEN=0
-        F  S DIEN=$O(^PXRMD(801.41,"AD",IEN,DIEN)) Q:'DIEN  D
-        .S DDATA=$G(^PXRMD(801.41,DIEN,0)) Q:DDATA=""
-        .S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4) Q:DNAME=""
-        .;Include only dialogs that are not part of this reminder dialog
-        .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) Q
-        .S LIST(DNAME)=DTYP
-        Q
-        ;
-        ;General help text routine.
-        ;--------------------------
-HLP(CALL)       ;
-        N HTEXT
-        N DIWF,DIWL,DIWR,IC
-        S DIWF="C75",DIWL=0,DIWR=75
-        ;
-        I CALL=1 D
-        .S HTEXT(1)="Enter 'Yes' to install all sub-components or"
-        .S HTEXT(2)="enter 'No' to install only the selected dialog."
-        I CALL=2 D
-        .S HTEXT(1)="Enter 'Yes' to install without changes."
-        .S HTEXT(2)="Enter 'No' to install with changes."
-        I CALL=3 D
-        .S HTEXT(1)="Select IFE to INSTALL reminder or dialog from this exchange"
-        .S HTEXT(2)="entry. Select DFE to DELETE this entry from the exchange file. "
-        .S HTEXT(3)="Select IH to view the installation HISTORY for this entry."
-        K ^UTILITY($J,"W")
-        S IC=""
-        F  S IC=$O(HTEXT(IC)) Q:IC=""  D
-        . S X=HTEXT(IC)
-        . D ^DIWP
-        W !
-        S IC=0
-        F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
-        . W !,^UTILITY($J,"W",0,IC,0)
-        K ^UTILITY($J,"W")
-        W !
-        Q
+PXRMEXIX ;SLC/PJH - Reminder Dialog Exchange checks. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=====================================================================
+ ;
+ ;Yes/No Prompts
+ ;--------------
+ASK(YESNO,TEXT,HELP) ;
+ W !
+ N DIR,X,Y
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="YA0"
+ M DIR("A")=TEXT
+ S DIR("B")="Y"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ S DIR("??")=U_"D HLP^PXRMEXIX(HELP)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) S PXRMDONE=1 Q
+ S YESNO=$E(Y(0))
+ Q
+ ;
+ ;Dialog check - all exist, none exist or some exist
+ ;--------------------------------------------------
+EXIST(ALL,DNAME,DTYP,INAME) ;
+ ;0 - None exist
+ ;1 - All exist
+ ;2 - Some exist
+ ;
+ ;Look for component dialogs in DMAP node from PXRMEXIC
+ N DONE,DOTHER,EXISTS,FILE,MODE
+ S ALL="",DONE=0,MODE="",NAME=""
+ ;
+ I DTYP="reminder dialog" D
+ .F  S NAME=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME)) Q:NAME=""  D  Q:DONE
+ ..;Check if dialog exists
+ ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME)
+ ..;If exists accumulate list of ancestors
+ ..I EXISTS D OTHER(NAME,.DOTHER)
+ ..;Quit if some exist and some don't
+ ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q
+ ..I MODE=0,EXISTS S MODE=2,DONE=1 Q
+ ..;Set all exists flag if dialog found
+ ..I MODE="",EXISTS S MODE=1
+ ..;Set none exists flag if dialog not found
+ ..I MODE="",'EXISTS S MODE=0
+ ;
+ I DTYP'="reminder dialog" D
+ .F  S NAME=$O(INAME(NAME)) Q:NAME=""  D  Q:DONE
+ ..;Treat namechanges as 'done'
+ ..I $D(PXRMNMCH(801.41,NAME)) Q
+ ..;Check if dialog exists
+ ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME)
+ ..;If exists accumulate list of ancestors
+ ..I EXISTS D OTHER(NAME,.DOTHER)
+ ..;Quit if some exist and some don't
+ ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q
+ ..I MODE=0,EXISTS S MODE=2,DONE=1 Q
+ ..;Set all exists flag if dialog found
+ ..I MODE="",EXISTS S MODE=1
+ ..;Set none exists flag if dialog not found
+ ..I MODE="",'EXISTS S MODE=0
+ ;
+ ;If all or none exist give option to install all without prompting
+ N ANS,TEXT
+ I MODE=0 D 
+ .S TEXT(1)="All dialog components for "_DNAME_" are new."
+ I MODE=1 D
+ .S TEXT(1)="All dialog components for "_DNAME_" already exist."
+ .S TEXT(2)="",TEXT(4)=""
+ .S TEXT(3)="Components not used by any other dialogs."
+ .;Warn if used by other dialogs
+ .I $D(DOTHER) D
+ ..S TEXT(3)="WARNING - some components already used by:"
+ ..N CNT,DLIT,DNAME,DTYP,FIRST,NAME
+ ..S CNT=4,DNAME="",TEXT(CNT)=""
+ ..F  S DNAME=$O(DOTHER(DNAME)) Q:DNAME=""  D
+ ...S NAME="",FIRST=1,CNT=CNT+1
+ ...S DTYP=DOTHER(DNAME)
+ ...I DTYP="R" S DTYP="Reminder Dialog"
+ ...I DTYP="G" S DTYP="Dialog Group"
+ ...I DTYP="E" S DTYP="Dialog Element"
+ ...;S CNT=CNT+1,FIRST=0,TEXT(CNT)=DLIT_NAME_" ("_DTYP_")"
+ ...S CNT=CNT+1,FIRST=0,TEXT(CNT)=DNAME_" ("_DTYP_")"
+ ..S CNT=CNT+1,TEXT(CNT)=""
+ S TEXT="Install "_DTYP_" and all components with no further changes:"
+ ;Give option to install all descendents
+ D ASK(.ANS,.TEXT,2) I $G(ANS)="Y" S ALL=1
+ Q
+ ;
+ ;Check if used by other dialogs
+ ;------------------------------
+OTHER(NAME,LIST) ;
+ N DDATA,DIEN,DNAME,DTYP,IEN
+ S IEN=$O(^PXRMD(801.41,"B",NAME,0)) Q:'IEN
+ ;Check if used by other dialogs
+ I '$D(^PXRMD(801.41,"AD",IEN)) Q
+ ;Build list of dialogs using this component
+ S DIEN=0
+ F  S DIEN=$O(^PXRMD(801.41,"AD",IEN,DIEN)) Q:'DIEN  D
+ .S DDATA=$G(^PXRMD(801.41,DIEN,0)) Q:DDATA=""
+ .S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4) Q:DNAME=""
+ .;Include only dialogs that are not part of this reminder dialog
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) Q
+ .S LIST(DNAME)=DTYP
+ Q
+ ;
+ ;General help text routine.
+ ;--------------------------
+HLP(CALL) ;
+ N HTEXT
+ N DIWF,DIWL,DIWR,IC
+ S DIWF="C75",DIWL=0,DIWR=75
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="Enter 'Yes' to if you are installing all sub-components or"
+ .S HTEXT(2)="enter 'No' to install only the selected dialog."
+ I CALL=2 D
+ .S HTEXT(1)="Enter 'Yes' to if you are installing without changes."
+ .S HTEXT(2)="enter 'No' to install with changes."
+ I CALL=3 D
+ .S HTEXT(1)="Select IFE to INSTALL reminder or dialog from this exchange"
+ .S HTEXT(2)="entry. Select DFE to DELETE this entry from the exchange file. "
+ .S HTEXT(3)="Select IH to view the installation HISTORY for this entry."
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
+ W !
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m

@@ -1 @@
-PXRMEXLB        ;SLC/PJH - Reminder Dialog Exchange. ;05/16/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=====================================================================
-        ;
-        ;Build list of dialog components - called once from PXRMEXLC
-        ;-------------------------------
-DBUILD(IND,NITEMS,FILENUM)      ;
-        N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,FILE,JND
-        N REPCNT,RESGRP,TEMPRESL,CNT
-        ;
-        K ^TMP("PXRMEXTMP",$J),^TMP("PXRMEXFND",$J)
-        ;
-        ;Scan dialog components in 120 and save name and type
-        S JND=0
-        F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND  D
-        .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA=""
-        .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3)
-        .;Extract dialog type and text and findings from exchange file
-        .D DPARSE
-        ;Scan dialog components in 120 and save dialog links
-        S JND="B",REPCNT=0
-        F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND),-1) Q:'JND  D
-        .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA=""
-        .S DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3)
-        .S DDLG=$P(DDATA,U),DSUB=DSTRT+2
-        .I JND=NITEMS D
-        ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAM")=DDLG
-        ..I $P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3)'["100~NATIONAL" Q
-        ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAT")=""
-        .F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:DSUB>DEND  D
-        ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB,0))
-        ..I ($P(DNODE,";")'="801.412")&($P(DNODE,";")'="801.41121")&($P(DNODE,";",3)'["118~") Q
-        ..S FILE=$P(DNODE,";")
-        ..S DNODE=$P(DNODE,";",3)
-        ..;;Modified Exchange to handle dialogs with replacement dialogs
-        ..I $E(DNODE,1,4)="118~" D
-        ...S DNAM=$P(DNODE,"~",2) Q:DNAM=""
-        ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
-        ...S REPCNT=REPCNT+1,^TMP("PXRMEXTMP",$J,"DREPL",REPCNT,DDLG)=DNAM_U_DLOC
-        ..I $E(DNODE,1,4)'=".01~" Q
-        ..S DSEQ=$P(DNODE,"~",2) Q:DSEQ=""
-        ..I FILE="801.41121" D  Q
-        ...S DNAM=$P(DNODE,"~",2) Q:DNAM=""
-        ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
-        ...S CNT=0
-        ...I $D(^TMP("PXRMEXTMP",$J,"DMAP",DDLG))>0 S CNT=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
-        ...S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,CNT+1)=DNAM_U_DLOC
-        ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB+1,0))
-        ..I ($P(DNODE,";")'="801.412") Q
-        ..S DNODE=$P(DNODE,";",3) I $E(DNODE,1,2)'="2~" Q
-        ..S DNAM=$P(DNODE,"~",2) Q:DNAM=""
-        ..S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
-        ..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ)=DNAM_U_DLOC
-        ;
-        ;Build index of dialog findings by name
-        N FDATA,FILENAM,FILENUM,FNAME
-        S IND=0
-        F  S IND=$O(^PXD(811.8,IEN,120,IND)) Q:'IND  D
-        .S FDATA=$G(^PXD(811.8,IEN,120,IND,0)) Q:FDATA=""
-        .S FILENAM=$P(FDATA,U),FILENUM=$P(FDATA,U,2) Q:FILENAM=""  Q:'FILENUM
-        .;Ignore reminder dialogs
-        .I FILENAM="REMINDER DIALOG" Q
-        .;Ignore reminder terms
-        .I FILENAM="REMINDER TERM" Q
-        .;Strip off trailing S in finding file name
-        .I $E(FILENAM,$L(FILENAM))="S" S $E(FILENAM,$L(FILENAM))=""
-        .S JND=0
-        .F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND  D
-        ..S FNAME=$P($G(^PXD(811.8,IEN,120,IND,1,JND,0)),U) Q:FNAME=""
-        ..;Save entry
-        ..S ^TMP("PXRMEXFND",$J,FNAME)=FILENUM_U_FILENAM_U_IND
-        I $D(TEMPRESL)>0 D
-        .S DDLG="" F  S DDLG=$O(TEMPRESL(DDLG)) Q:DDLG=""  D
-        ..;S ^TMP("PXRMEXTMP",$J,"RESULT",DDLG,TEMPRESL(DDLG))=""
-        ..S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
-        ..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ+1)=TEMPRESL(DDLG)_U_RESGRP(TEMPRESL(DDLG))
-        Q
-        ;
-        ;Scan exchange file to get dialog fields
-        ;---------------------------------------
-DPARSE  N DCNT,DFIND,DFIAD,DFNAM,DFQUIT,DLCT,DLINES,DSUB,DTEXT,DTXT,DTYP
-        ;
-        ;Find where all the field numbers are kept
-        N DARRAY,DDATA,DFNUM,DRAW,DSTRING,RESNAM
-        S DSUB=DSTRT-1,DSTRING=";.01;4;5;15;24;25;55;"
-        ;S DSUB=DSTRT,DSTRING=";4;5;15;24;25;"
-        F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:'DSUB  D  Q:DSUB>DEND
-        .S DDATA=$G(^PXD(811.8,IEN,100,DSUB,0)) Q:DDATA=""
-        .I $P(DDATA,";")'=801.41 Q
-        .S DFNUM=$P(DDATA,";",3),DFNUM=$P(DFNUM,"~") Q:DFNUM=""
-        .I DSTRING[(";"_DFNUM_";") S DARRAY(DFNUM)=DSUB
-        .I $P(DDATA,";")="801.41121" S DARRAY(55)=DSUB
-        ;
-        ;Determine dialog component type
-        S DSUB=DARRAY(4) Q:'DSUB
-        S DTYP=$P($G(^PXD(811.8,IEN,100,DSUB,0)),"~",2)
-        I DTYP'["result" S:DTYP[" " DTYP=$P(DTYP," ",2) S:DTYP="value" DTYP="forced"
-        ;
-        ;Initialise text and finding fields
-        S DTXT="*NONE*",DFIND=""
-        ;Get text appropriate for the type of component
-        I ((DTYP="element")!(DTYP="group"))&(DTYP'["result") D
-        .;search for WP text
-        .S DSUB=$G(DARRAY(25)) D:DSUB
-        ..S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
-        ..;Get the line count
-        ..S DLINES=$P(DTEXT,"~",3),DCNT=0
-        ..;Get the wp text lines
-        ..F DLCT=DSUB+1:1:DSUB+DLINES D
-        ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0))
-        ...S DCNT=DCNT+1,DTXT(DCNT)=DTEXT
-        ...;Check for embedded TIU templates
-        ...D DTIU(DNAM,DTEXT)
-        ..;Reformat text to 50 characters
-        ..D DWP(.DTXT)
-        ..;Search for Result Group/Element
-        ..S DSUB=$G(DARRAY(55)) I DSUB>0 D
-        ...S RESNAME=$P($P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3),"~",2)
-        ...S TEMPRESL(DNAM)=RESNAME
-        .;Search for finding item
-        .S DSUB=$G(DARRAY(15)) D:DSUB
-        ..S DFIND=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DFIND=""
-        ..;Finding name
-        ..S DFIND=$P(DFIND,"~",2) Q:DFIND=""
-        ..I $P(DFIND,".")="ICD9" S DFIND=$P(DFIND," ")
-        .;
-        .;Search for additional finding - start after WP text
-        .S DSUB=+$G(DARRAY(25)) D:DSUB
-        ..S DCNT=0,DFQUIT=0
-        ..F DLCT=DSUB+1+DLINES:1 D  Q:DFQUIT  Q:DLCT>DEND
-        ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0))
-        ...;Ignore line if this is not an additional finding
-        ...I $P(DTEXT,";")'=801.4118 S:$P(DTEXT,";")>801.4118 DFQUIT=1 Q
-        ...S DFNAM=$P(DTEXT,"~",2) Q:DFNAM=""
-        ...I $P(DFNAM,".")="ICD9" S DFNAM=$P(DFNAM," ")
-        ...S DCNT=DCNT+1,DFIAD(DCNT)=DFNAM
-        ;
-        I DTYP["result" D
-        .S DSUB=$G(DARRAY(.01)) Q:'DSUB
-        .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
-        .S DTXT=$P(DTEXT,"~",2)
-        .S RESGRP(DNAM)=DSTRT_U_DEND_U_IND_U_JND
-        ;
-        I DTYP="prompt" D
-        .;search for prompt caption
-        .S DSUB=$G(DARRAY(24)) Q:'DSUB
-        .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
-        .S DTXT=$P(DTEXT,"~",2)
-        ;
-        I DTYP="group" D
-        .;search for group caption
-        .S DSUB=$G(DARRAY(5)) Q:'DSUB
-        .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
-        .S DTXT=$P(DTEXT,"~",2)
-        .Q
-        ;
-        ;Save dialog type
-        S ^TMP("PXRMEXTMP",$J,"DTYP",DNAM)=DTYP
-        ;Save dialog component text (first line only)
-        S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM)=DTXT
-        ;
-        ;Save main finding
-        I DFIND]"" S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,1)=$P(DFIND,".",2,99)
-        ;Save additional findings
-        S DSUB=0
-        F   S DSUB=$O(DFIAD(DSUB)) Q:'DSUB  D
-        .S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB+1)=$P(DFIAD(DSUB),".",2,99)
-        ;
-        ;Save additional WP text lines
-        S DSUB=0
-        F   S DSUB=$O(DTXT(DSUB)) Q:'DSUB  D
-        .S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)=DTXT(DSUB)
-        ;
-        ;Save dialog's position in exchange file
-        S ^TMP("PXRMEXTMP",$J,"DLOC",DNAM)=DSTRT_U_DEND_U_IND_U_JND
-        Q
-        ;
-        ;Extract any TIU templates
-        ;-------------------------
-DTIU(DNAM,TEXT) ;
-        N IC,TCNT,TLIST,TNAM
-        ;Templates are in format {FLD:fldname}
-        S TCNT=0 D TIUXTR^PXRMEXDG("{FLD:","}",TEXT,.TLIST,.TCNT) Q:'TCNT
-        ;
-        F IC=1:1:TCNT D
-        .S TNAM=$G(TLIST(TCNT)) Q:TNAM=""
-        .S ^TMP("PXRMEXTMP",$J,"DTIU",DNAM,TNAM)=""
-        Q
-        ;
-        ;Process WP fields
-        ;-----------------
-DWP(TEXT)       ;
-        N DIWF,DIWL,DIWR,IC,X
-        S DIWF="C50",DIWL=0,DIWR=50
-        ;
-        K ^UTILITY($J,"W")
-        S IC=""
-        F  S IC=$O(TEXT(IC)) Q:IC=""  D
-        .S X=TEXT(IC)
-        .D ^DIWP
-        ;
-        K TEXT
-        S IC=0
-        F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
-        .S DTEXT=$G(^UTILITY($J,"W",0,IC,0))
-        .I IC=1 S TEXT=DTEXT Q
-        .S TEXT(IC-1)=DTEXT
-        ;
-        K ^UTILITY($J,"W")
-        Q
+PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;07/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=====================================================================
+ ;
+ ;Build list of dialog components - called once from PXRMEXLC
+ ;-------------------------------
+DBUILD(IND,NITEMS,FILENUM) ;
+ N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,JND
+ ;
+ K ^TMP("PXRMEXTMP",$J),^TMP("PXRMEXFND",$J)
+ ;
+ ;Scan dialog components in 120 and save name and type
+ S JND=0
+ F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND  D
+ .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA=""
+ .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3)
+ .;Extract dialog type and text and findings from exchange file
+ .D DPARSE
+ ;Scan dialog components in 120 and save dialog links
+ S JND="B"
+ F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND),-1) Q:'JND  D
+ .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA=""
+ .S DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3)
+ .S DDLG=$P(DDATA,U),DSUB=DSTRT+2
+ .I JND=NITEMS D
+ ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAM")=DDLG
+ ..I $P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3)'["100~NATIONAL" Q
+ ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAT")=""
+ .F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:DSUB>DEND  D
+ ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB,0))
+ ..I $P(DNODE,";")'="801.412"&($P(DNODE,";",3)'["118~") Q
+ ..S DNODE=$P(DNODE,";",3)
+ ..;;Modified Exchange to handle dialogs with replacement dialogs
+ ..I $E(DNODE,1,4)="118~" D
+ ...S DNAM=$P(DNODE,"~",2) Q:DNAM=""
+ ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
+ ...S ^TMP("PXRMEXTMP",$J,"DREPL",DDLG)=DNAM_U_DLOC
+ ..I $E(DNODE,1,4)'=".01~" Q
+ ..S DSEQ=$P(DNODE,"~",2) Q:DSEQ=""
+ ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB+1,0)) I $P(DNODE,";")'="801.412" Q
+ ..S DNODE=$P(DNODE,";",3) I $E(DNODE,1,2)'="2~" Q
+ ..S DNAM=$P(DNODE,"~",2) Q:DNAM=""
+ ..S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
+ ..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ)=DNAM_U_DLOC
+ ;
+ ;Build index of dialog findings by name
+ ;
+ ;
+ N FDATA,FILENAM,FILENUM,FNAME
+ S IND=0
+ F  S IND=$O(^PXD(811.8,IEN,120,IND)) Q:'IND  D
+ .S FDATA=$G(^PXD(811.8,IEN,120,IND,0)) Q:FDATA=""
+ .S FILENAM=$P(FDATA,U),FILENUM=$P(FDATA,U,2) Q:FILENAM=""  Q:'FILENUM
+ .;Ignore reminder dialogs
+ .I FILENAM="REMINDER DIALOG" Q
+ .;Ignore reminder terms
+ .I FILENAM="REMINDER TERM" Q
+ .;Strip off trailing S in finding file name
+ .I $E(FILENAM,$L(FILENAM))="S" S $E(FILENAM,$L(FILENAM))=""
+ .S JND=0
+ .F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND  D
+ ..S FNAME=$P($G(^PXD(811.8,IEN,120,IND,1,JND,0)),U) Q:FNAME=""
+ ..;Save entry
+ ..S ^TMP("PXRMEXFND",$J,FNAME)=FILENUM_U_FILENAM_U_IND
+ Q
+ ;
+ ;Scan exchange file to get dialog fields
+ ;---------------------------------------
+DPARSE N DCNT,DFIND,DFIAD,DFNAM,DFQUIT,DLCT,DLINES,DSUB,DTEXT,DTXT,DTYP
+ ;
+ ;Find where all the field numbers are kept
+ N DARRAY,DDATA,DFNUM,DRAW,DSTRING
+ S DSUB=DSTRT,DSTRING=";4;5;15;24;25;"
+ F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:'DSUB  D  Q:DSUB>DEND
+ .S DDATA=$G(^PXD(811.8,IEN,100,DSUB,0)) Q:DDATA=""
+ .I $P(DDATA,";")'=801.41 Q
+ .S DFNUM=$P(DDATA,";",3),DFNUM=$P(DFNUM,"~") Q:DFNUM=""
+ .I DSTRING[(";"_DFNUM_";") S DARRAY(DFNUM)=DSUB
+ ;
+ ;Determine dialog component type
+ S DSUB=DARRAY(4) Q:'DSUB
+ S DTYP=$P($G(^PXD(811.8,IEN,100,DSUB,0)),"~",2)
+ S:DTYP[" " DTYP=$P(DTYP," ",2) S:DTYP="value" DTYP="forced"
+ ;
+ ;Initialise text and finding fields
+ S DTXT="*NONE*",DFIND=""
+ ;Get text appropriate for the type of component
+ I (DTYP="element")!(DTYP="group") D
+ .;search for WP text
+ .S DSUB=$G(DARRAY(25)) D:DSUB
+ ..S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
+ ..;Get the line count
+ ..S DLINES=$P(DTEXT,"~",3),DCNT=0
+ ..;Get the wp text lines
+ ..F DLCT=DSUB+1:1:DSUB+DLINES D
+ ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0))
+ ...S DCNT=DCNT+1,DTXT(DCNT)=DTEXT
+ ...;Check for embedded TIU templates
+ ...D DTIU(DNAM,DTEXT)
+ ..;Reformat text to 50 characters
+ ..D DWP(.DTXT)
+ .;
+ .;Search for finding item
+ .S DSUB=$G(DARRAY(15)) D:DSUB
+ ..S DFIND=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DFIND=""
+ ..;Finding name
+ ..S DFIND=$P(DFIND,"~",2) Q:DFIND=""
+ ..I $P(DFIND,".")="ICD9" S DFIND=$P(DFIND," ")
+ .;
+ .;Search for additional finding - start after WP text
+ .S DSUB=+$G(DARRAY(25)) D:DSUB
+ ..S DCNT=0,DFQUIT=0
+ ..F DLCT=DSUB+1+DLINES:1 D  Q:DFQUIT  Q:DLCT>DEND
+ ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0))
+ ...;Ignore line if this is not an additional finding
+ ...I $P(DTEXT,";")'=801.4118 S:$P(DTEXT,";")>801.4118 DFQUIT=1 Q
+ ...S DFNAM=$P(DTEXT,"~",2) Q:DFNAM=""
+ ...I $P(DFNAM,".")="ICD9" S DFNAM=$P(DFNAM," ")
+ ...S DCNT=DCNT+1,DFIAD(DCNT)=DFNAM
+ ;
+ I DTYP="prompt" D
+ .;search for prompt caption
+ .S DSUB=$G(DARRAY(24)) Q:'DSUB
+ .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
+ .S DTXT=$P(DTEXT,"~",2)
+ ;
+ I DTYP="group" D
+ .;search for group caption
+ .S DSUB=$G(DARRAY(5)) Q:'DSUB
+ .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
+ .S DTXT=$P(DTEXT,"~",2)
+ .Q
+ ;
+ ;Save dialog type
+ S ^TMP("PXRMEXTMP",$J,"DTYP",DNAM)=DTYP
+ ;Save dialog component text (first line only)
+ S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM)=DTXT
+ ;
+ ;Save main finding
+ I DFIND]"" S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,1)=$P(DFIND,".",2,99)
+ ;Save additional findings
+ S DSUB=0
+ F   S DSUB=$O(DFIAD(DSUB)) Q:'DSUB  D
+ .S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB+1)=$P(DFIAD(DSUB),".",2,99)
+ ;
+ ;Save additional WP text lines
+ S DSUB=0
+ F   S DSUB=$O(DTXT(DSUB)) Q:'DSUB  D
+ .S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)=DTXT(DSUB)
+ ;
+ ;Save dialog's position in exchange file
+ S ^TMP("PXRMEXTMP",$J,"DLOC",DNAM)=DSTRT_U_DEND_U_IND_U_JND
+ Q
+ ;
+ ;Extract any TIU templates
+ ;-------------------------
+DTIU(DNAM,TEXT) ;
+ N IC,TCNT,TLIST,TNAM
+ ;Templates are in format {FLD:fldname}
+ S TCNT=0 D TIUXTR^PXRMEXDG("{FLD:","}",TEXT,.TLIST,.TCNT) Q:'TCNT
+ ;
+ F IC=1:1:TCNT D
+ .S TNAM=$G(TLIST(TCNT)) Q:TNAM=""
+ .S ^TMP("PXRMEXTMP",$J,"DTIU",DNAM,TNAM)=""
+ Q
+ ;
+ ;Process WP fields
+ ;-----------------
+DWP(TEXT) ;
+ N DIWF,DIWL,DIWR,IC,X
+ S DIWF="C50",DIWL=0,DIWR=50
+ ;
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(TEXT(IC)) Q:IC=""  D
+ .S X=TEXT(IC)
+ .D ^DIWP
+ ;
+ K TEXT
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ .S DTEXT=$G(^UTILITY($J,"W",0,IC,0))
+ .I IC=1 S TEXT=DTEXT Q
+ .S TEXT(IC-1)=DTEXT
+ ;
+ K ^UTILITY($J,"W")
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m

@@ -1 @@
-PXRMEXLC        ; SLC/PKR/PJH - Routines to display repository entry components. ;08/03/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;======================================================
-BLDLIST(FORCE)  ;Build a list of all repository entries.
-        ;If FORCE is true then force rebuilding of the list.
-        I FORCE K ^TMP("PXRMEXLR",$J)
-        I $D(^TMP("PXRMEXLR",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
-        E  D
-        . D REXL^PXRMLIST("PXRMEXLR")
-        . S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
-        Q
-        ;
-        ;======================================================
-CDISP(IEN)      ;Format component list for display.
-        N CAT,CMPNT,END,EOKTI,EXISTS,FILENUM,FOKTI,IND,INDEX,JND,JNDS,KND
-        N MSG,NCMPNT,NDLINE,NDSEL,NITEMS,NLINE,NSEL,PT01,START,TEMP,TEMP0,TYPE
-        K ^TMP("PXRMEXLC",$J),^TMP("PXRMEXLD",$J)
-        S (NDLINE,NLINE)=0
-        S (NDSEL,NSEL)=1
-        ;Load the description.
-        F IND=1:1:$P(^PXD(811.8,IEN,110,0),U,4) D
-        . S NLINE=NLINE+1
-        . S ^TMP("PXRMEXLC",$J,NLINE,0)=^PXD(811.8,IEN,110,IND,0)
-        . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
-        S NLINE=NLINE+1
-        S ^TMP("PXRMEXLC",$J,NLINE,0)=" "
-        S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
-        S NCMPNT=^PXD(811.8,IEN,119)
-        ;Load the text for display.
-        F IND=1:1:NCMPNT D
-        . S NLINE=NLINE+1
-        . S TEMP=^PXD(811.8,IEN,120,IND,0)
-        . S ^TMP("PXRMEXLC",$J,NLINE,0)=$P(TEMP,U,1)
-        . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
-        . S FILENUM=$P(TEMP,U,2)
-        . S FOKTI=$$FOKTI^PXRMEXFI(FILENUM)
-        . S NITEMS=$P(TEMP,U,3)
-        . I $P(TEMP,U,1)="REMINDER DIALOG" D
-        ..;Save details of the dialog in ^TMP("PXRMEXTMP")
-        .. S JNDS=NITEMS D DBUILD^PXRMEXLB(IND,NITEMS,FILENUM)
-        . E  S JNDS=1
-        . F JND=JNDS:1:NITEMS D
-        .. S TEMP=^PXD(811.8,IEN,120,IND,1,JND,0)
-        .. S EOKTI=FOKTI
-        .. S PT01=$P(TEMP,U,1)
-        .. S EXISTS=$S(FILENUM=0:$$EXISTS^PXRMEXCF(PT01),1:$$EXISTS^PXRMEXIU(FILENUM,PT01,"W"))
-        ..;If this is an education topic and it starts with VA- it
-        ..;cannot be transported because of PCE's screen.
-        .. ;I (FILENUM=9999999.09)&(PT01["VA-") S EOKTI=0
-        ..;If this is a health factor see if it is a category.
-        .. S CAT=""
-        .. I (FILENUM=9999999.64) D
-        ... S TYPE=""
-        ... S START=$P(TEMP,U,2)
-        ... S END=$P(TEMP,U,3)
-        ... F KND=START:1:END D
-        .... S TEMP0=$P(^PXD(811.8,IEN,100,KND,0),";",3)
-        .... I $P(TEMP0,"~",1)=.1 S TYPE=$P(TEMP0,"~",2)
-        ... I TYPE="CATEGORY" S CAT="X"
-        .. S NLINE=NLINE+1
-        .. I IND=1,JND=1 S NSEL=1,INDEX=$S(EOKTI:NSEL,1:"")
-        .. E  D
-        ...;If entries in this file are ok to install add them to the
-        ...;selectable list. Make sure the first selectable entry exists
-        ...;before incrementing NSEL.
-        ... I EOKTI S NSEL=$S($D(^TMP("PXRMEXLC",$J,"SEL",1)):NSEL+1,1:NSEL),INDEX=NSEL
-        ... E  S INDEX=""
-        .. S ^TMP("PXRMEXLC",$J,NLINE,0)=$$FMTDATA(INDEX,PT01,CAT,EXISTS)
-        .. S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
-        ..;Store the file number, node 120 indexes and the ien if it exists.
-        .. I INDEX=NSEL S ^TMP("PXRMEXLC",$J,"SEL",NSEL)=FILENUM_U_IND_U_JND_U_EXISTS
-        . S NLINE=NLINE+1
-        . S ^TMP("PXRMEXLC",$J,NLINE,0)=""
-        . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
-        Q
-        ;
-        ;======================================================
-FMTDATA(NSEL,PT01,CAT,EXISTS)   ;Format items for display.
-        N NSTI,TEMP
-        S TEMP=$$RJ^XLFSTR(NSEL,4," ")_"  "_$E(PT01,1,54)
-        I CAT="X" D
-        . S NSTI=63-$L(TEMP)
-        . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X"
-        I EXISTS D
-        . S NSTI=75-$L(TEMP)
-        . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X"
-        Q TEMP
-        ;
-        ;======================================================
-INSCHR(NUM,CHR) ;Return a string of NUM characters (CHR).
-        N IND,TEMP
-        S TEMP=""
-        I NUM<1 Q TEMP
-        F IND=1:1:NUM S TEMP=TEMP_CHR
-        Q TEMP
-        ;
-        ;======================================================
-ORDER(STRING,ORDER)     ;Rebuild string in ascending or descending order.
-        N ARRAY,ITEM,CNT
-        F CNT=1:1 S ITEM=$P(STRING,",",CNT) Q:'ITEM  S ARRAY(ITEM)=""
-        K STRING
-        F CNT=1:1 S ITEM=$O(ARRAY(ITEM),ORDER) Q:'ITEM  D
-        .S $P(STRING,",",CNT)=ITEM
-        Q
-        ;
+PXRMEXLC ; SLC/PKR/PJH - Routines to display repository entry components. ;06/22/2004
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;======================================================
+BLDLIST(FORCE) ;Build a list of all repository entries.
+ ;If FORCE is true then force rebuilding of the list.
+ I FORCE K ^TMP("PXRMEXLR",$J)
+ I $D(^TMP("PXRMEXLR",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
+ E  D
+ . N IEN,RELIST
+ . D RE^PXRMLIST(.RELIST,.IEN)
+ . M ^TMP("PXRMEXLR",$J)=RELIST
+ . S VALMCNT=RELIST("VALMCNT")
+ . F IND=1:1:VALMCNT S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
+ ;======================================================
+CDISP(IEN) ;Format component list for display.
+ N CAT,CMPNT,END,EOKTI,EXISTS,FILENUM,FOKTI,IND,INDEX,JND,JNDS,KND
+ N MSG,NCMPNT,NDLINE,NDSEL,NITEMS,NLINE,NSEL,PT01,START,TEMP,TEMP0,TYPE
+ K ^TMP("PXRMEXLC",$J),^TMP("PXRMEXLD",$J)
+ S (NDLINE,NLINE)=0
+ S (NDSEL,NSEL)=1
+ ;Load the description.
+ F IND=1:1:$P(^PXD(811.8,IEN,110,0),U,4) D
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXLC",$J,NLINE,0)=^PXD(811.8,IEN,110,IND,0)
+ . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
+ S NLINE=NLINE+1
+ S ^TMP("PXRMEXLC",$J,NLINE,0)=" "
+ S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
+ S NCMPNT=^PXD(811.8,IEN,119)
+ ;Load the text for display.
+ F IND=1:1:NCMPNT D
+ . S NLINE=NLINE+1
+ . S TEMP=^PXD(811.8,IEN,120,IND,0)
+ . S ^TMP("PXRMEXLC",$J,NLINE,0)=$P(TEMP,U,1)
+ . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
+ . S FILENUM=$P(TEMP,U,2)
+ . S FOKTI=$$FOKTI^PXRMEXFI(FILENUM)
+ . S NITEMS=$P(TEMP,U,3)
+ . I $P(TEMP,U,1)="REMINDER DIALOG" D
+ ..;Save details of the dialog in ^TMP("PXRMEXTMP")
+ .. S JNDS=NITEMS D DBUILD^PXRMEXLB(IND,NITEMS,FILENUM)
+ . E  S JNDS=1
+ . F JND=JNDS:1:NITEMS D
+ .. S TEMP=^PXD(811.8,IEN,120,IND,1,JND,0)
+ .. S EOKTI=FOKTI
+ .. S PT01=$P(TEMP,U,1)
+ .. S EXISTS=$S(FILENUM=0:$$EXISTS^PXRMEXCF(PT01),1:$$EXISTS^PXRMEXIU(FILENUM,PT01,"W"))
+ ..;If this is an education topic and it starts with VA- it
+ ..;cannot be transported because of PCE's screen.
+ .. ;I (FILENUM=9999999.09)&(PT01["VA-") S EOKTI=0
+ ..;If this is a health factor see if it is a category.
+ .. S CAT=""
+ .. I (FILENUM=9999999.64) D
+ ... S TYPE=""
+ ... S START=$P(TEMP,U,2)
+ ... S END=$P(TEMP,U,3)
+ ... F KND=START:1:END D
+ .... S TEMP0=$P(^PXD(811.8,IEN,100,KND,0),";",3)
+ .... I $P(TEMP0,"~",1)=.1 S TYPE=$P(TEMP0,"~",2)
+ ... I TYPE="CATEGORY" S CAT="X"
+ .. S NLINE=NLINE+1
+ .. I IND=1,JND=1 S NSEL=1,INDEX=$S(EOKTI:NSEL,1:"")
+ .. E  D
+ ...;If entries in this file are ok to install add them to the
+ ...;selectable list. Make sure the first selectable entry exists
+ ...;before incrementing NSEL.
+ ... I EOKTI S NSEL=$S($D(^TMP("PXRMEXLC",$J,"SEL",1)):NSEL+1,1:NSEL),INDEX=NSEL
+ ... E  S INDEX=""
+ .. S ^TMP("PXRMEXLC",$J,NLINE,0)=$$FMTDATA(INDEX,PT01,CAT,EXISTS)
+ .. S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
+ ..;Store the file number, node 120 indexes and the ien if it exists.
+ .. I INDEX=NSEL S ^TMP("PXRMEXLC",$J,"SEL",NSEL)=FILENUM_U_IND_U_JND_U_EXISTS
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXLC",$J,NLINE,0)=""
+ . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)=""
+ Q
+ ;
+ ;======================================================
+DDISP(IND,NITEMS,FILENUM) ;Setup dialog display list.
+ N JND,NLINE,NSEL,TEMP
+ S (NLINE,NSEL)=0
+ F JND=1:1:NITEMS D
+ . S TEMP=^PXD(811.8,IEN,120,IND,1,JND,0)
+ . S PT01=$P(TEMP,U,1)
+ . S EXISTS=$$EXISTS^PXRMEXIU(FILENUM,PT01,"W")
+ . S NLINE=NLINE+1
+ . S NSEL=NSEL+1
+ . S ^TMP("PXRMEXLD",$J,NLINE,0)=$$FMTDATA(NSEL,PT01,CAT,EXISTS)
+ . S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;Store the file number, start and stop line in the repository.
+ . S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_$P(TEMP,U,2,3)
+ Q
+ ;
+ ;======================================================
+FMTDATA(NSEL,PT01,CAT,EXISTS) ;Format items for display.
+ N NSTI,TEMP
+ S TEMP=$$RJ^XLFSTR(NSEL,4," ")_"  "_$E(PT01,1,54)
+ I CAT="X" D
+ . S NSTI=63-$L(TEMP)
+ . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X"
+ I EXISTS D
+ . S NSTI=75-$L(TEMP)
+ . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X"
+ Q TEMP
+ ;
+ ;======================================================
+HISTLIST(LIST,VALMCNT) ;Build a list of install histories in
+ ;^TMP("PXRMEXIH",$J).
+ N DATE,DC,ENTRY,IHIND,IND,INDONE,NLINE,NSEL,RIEN,SOURCE,TEMP,USER
+ K ^TMP("PXRMEXIH",$J)
+ S (NLINE,NSEL)=0
+ S IND=""
+ F  S IND=$O(LIST(IND)) Q:IND=""  D
+ . S RIEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
+ . I $D(^PXD(811.8,RIEN,130)) S INDONE=1
+ . E  S INDONE=0
+ . S TEMP=^PXD(811.8,RIEN,0)
+ . S ENTRY=$P(TEMP,U,1)
+ . S SOURCE=$P(TEMP,U,2)
+ . S DATE=$P(TEMP,U,3)
+ . S NLINE=NLINE+1
+ . I INDONE S NSEL=NSEL+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)=$$FRE^PXRMLIST(" ",ENTRY,SOURCE,DATE)
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)="     Installation Date       Installed By"
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)="     -----------------       ------------"
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . I 'INDONE D  Q
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)="      none"
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)=" "
+ . S DATE="",DC=0
+ . F  S DATE=$O(^PXD(811.8,RIEN,130,"B",DATE)) Q:DATE=""  D
+ .. S NLINE=NLINE+1
+ .. S DC=DC+1
+ .. I DC>1 S NSEL=NSEL+1
+ .. S IHIND=$O(^PXD(811.8,RIEN,130,"B",DATE,""))
+ .. S TEMP=^PXD(811.8,RIEN,130,IHIND,0)
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)=$$RJ^XLFSTR(NSEL,4," ")_" "_$$FMTE^XLFDT($P(TEMP,U,1),"5Z")_"   "_$P(TEMP,U,2)
+ .. S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ .. S ^TMP("PXRMEXIH",$J,"SEL",NSEL)=RIEN_U_IHIND
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)=" "
+ . S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ S VALMCNT=NLINE
+ Q
+ ;
+ ;======================================================
+INSCHR(NUM,CHR) ;Return a string of NUM characters (CHR).
+ N IND,TEMP
+ S TEMP=""
+ I NUM<1 Q TEMP
+ F IND=1:1:NUM S TEMP=TEMP_CHR
+ Q TEMP
+ ;
+ ;======================================================
+DREPL ;
+ N STR,I
+ K PXRMEXOR
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ S STR="" F I=1:1:30 S STR=STR_"-"
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J(STR_" REPLACEMENT ITEMS "_STR,79)
+DREPL1 ;
+ M ^TMP($J,"PXRMEXREP")=PXRMEXRP
+ K PXRMEXRP
+ ;S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)="
+ N CNT,DLG,DDATA,DDLG,DEND,DNAM,DREP,DSTRT,IND,JND,LEV,TEMP
+ ;S LEV="" F  S LEV=$O(^TMP($J,"PXRMEXREP",LEV)) Q:LEV=""  D
+ S LEV=0
+ S DLG="" F  S DLG=$O(^TMP($J,"PXRMEXREP",DLG)) Q:DLG=""  D
+ .S DDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",DLG)) Q:DDATA=""
+ .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ .I $D(PXRMEXOR(DNAM))>0 Q
+ .S PXRMEXOR(DNAM)=""
+ .S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Check if this component has been replaced
+ .S LEV=LEV+1
+ .S DREP=$G(PXRMNMCH(FILENUM,DNAM)) I DREP=DNAM S DREP=""
+ .;Save line in workfile
+ .S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ .S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .D DLINE^PXRMEXLD(DNAM,LEV,"")
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP^PXRMEXLD(DNAM,LEV)
+ K ^TMP($J,"PXRMEXREP")
+ I $D(PXRMEXRP)>0 D DREPL1
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m

@@ -1 @@
-PXRMEXLD        ;SLC/PJH - Reminder Dialog Exchange Main Routine. ;08/07/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-START   N PXRMBG,PXRMMODE,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ
-        S X="IORESET"
-        D EN^VALM("PXRM EX LIST DIALOG")
-        ;Rebuild Display
-        D CDISP^PXRMEXLC(PXRMRIEN)
-        Q
-        ;
-ENTRY   ; Entry point for List Manager
-        D FIND Q
-        ;
-DETAIL  ;Detailed display
-        S PXRMMODE=0 D DISP(PXRMMODE) Q
-        ;
-FIND    ;Display findings
-        S PXRMMODE=2 D DISP(PXRMMODE) Q
-        ;
-SUM     ;Display dialog summary
-        S PXRMMODE=3 D DISP(PXRMMODE) Q
-        ;
-USE     ;Display dialog usage
-        S PXRMMODE=4 D DISP(PXRMMODE) Q
-        ;
-TEXT    ;Display dialog text
-        S PXRMMODE=1 D DISP(PXRMMODE) Q
-        ;
-EXIT    ;
-        K ^TMP("PXRMEXLD",$J)
-        Q
-        ;
-DISP(VIEW)      ;Build the requested view and display it.
-        D BLDDISP^PXRMEXD1(VIEW)
-        ;Change header
-        I VIEW=0 D CHGCAP^VALM("HEADER2","Dialog Details")
-        I VIEW=1 D CHGCAP^VALM("HEADER2","Dialog Text")
-        I VIEW=2 D CHGCAP^VALM("HEADER2","Dialog Findings")
-        I VIEW=3 D CHGCAP^VALM("HEADER2","Dialog Summary")
-        I VIEW=4 D CHGCAP^VALM("HEADER2","Dialog Usage")
-        S VALMCNT=^TMP("PXRMEXLD",$J,"VALMCNT"),VALMBG=1,VALMBCK="R"
-        ;Reset protocol
-        D XQORM
-        Q
-        ;
-HELP    ;
-        N ORU,ORUPRMT,XQORM,PXRMTAG
-        S PXRMTAG="DLG"
-        D EN^VALM("PXRM EX DIALOG HELP")
-        Q
-        ;
-HDR     ;
-        S VALMHDR(1)="Packed reminder dialog: "
-        S VALMHDR(1)=VALMHDR(1)_$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
-        I $D(^TMP("PXRMEXTMP",$J,"PXRMDNAT")) S VALMHDR(1)=VALMHDR(1)_" [NATIONAL DIALOG]"
-        S VALMHDR("TITLE")=VALMHDR(1)
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-PEXIT   ;PXRM EXCH DIALOG MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-VALID(STRING)   ;Validate sequence numbers
-        N CNT,FOUND,OK
-        S FOUND=0,OK=1
-        F CNT=1:1 S SEL=$P(STRING,",",CNT) Q:'SEL  D
-        .;Invalid selection
-        .I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
-        ..S OK=0 W $C(7),!,SEL_" is not a valid item number." H 2
-        .S FOUND=1
-        Q:OK&FOUND 1
-        Q 0
-        ;
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT DIALOG",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Action: "
-        Q
-        ;
-XSEL    ;PXRM EXCH SELECT DIALOG validation
-        N ALL,CNT,ERR,IEN,IND,PXRMDONE,SELECT,SEL
-        S ALL="",PXRMDONE=0,PXRMBG=$G(VALMBG)
-        ;Invalid selection
-        S SELECT=$P(XQORNOD(0),"=",2) I '$$VALID(SELECT) S VALMBCK="R" Q
-        ;
-        ;Sort the SELECTION into reverse order
-        D ORDER^PXRMEXLC(.SELECT,-1)
-        ;
-        ;Lock the file
-        I '$$LOCK^PXRMEXID S VALMBCK="R" Q
-        ;
-        ;Install dialog component(s)
-        S CNT=0
-        F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL  D  Q:PXRMDONE
-        .D INSCOM^PXRMEXID(SEL,0)
-        ;
-        ;Unlock file
-        D UNLOCK^PXRMEXID
-        ;
-        ;Rebuild Workfile
-        D DISP^PXRMEXLD(PXRMMODE)
-        ;
-        ;Refresh
-        S VALMBCK="R" I $D(PXRMBG) S VALMBG=PXRMBG
-        Q
+PXRMEXLD ;SLC/PJH - Reminder Dialog Exchange Main Routine. ;7/01/2004
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=====================================================================
+START N PXRMBG,PXRMMODE,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ
+ S X="IORESET"
+ D EN^VALM("PXRM EX LIST DIALOG")
+ ;
+ ;Rebuild Display
+ D CDISP^PXRMEXLC(PXRMRIEN)
+ Q
+ ;
+ENTRY D FIND Q
+ ;
+DETAIL S PXRMMODE=0 D DISP(PXRMMODE) Q
+ ;
+ ;Display Findings
+ ;--------------------------
+FIND S PXRMMODE=2 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Summary
+ ;----------------------
+SUM S PXRMMODE=3 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Usage
+ ;--------------------
+USE S PXRMMODE=4 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Text
+ ;-------------------
+TEXT S PXRMMODE=1 D DISP(PXRMMODE) Q
+ ;
+EXIT K ^TMP("PXRMEXLD",$J) Q
+ ;
+PEXIT ;PXRM EXCH DIALOG MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+HELP N ORU,ORUPRMT,XQORM,PXRMTAG S PXRMTAG="DLG"
+ D EN^VALM("PXRM EX DIALOG HELP")
+ Q
+ ;
+HDR S VALMHDR(1)="Packed reminder dialog: "
+ S VALMHDR(1)=VALMHDR(1)_$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
+ I $D(^TMP("PXRMEXTMP",$J,"PXRMDNAT")) D
+ .S VALMHDR(1)=VALMHDR(1)_" [NATIONAL DIALOG]"
+ S VALMHDR("TITLE")=VALMHDR(1)
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+ ;Build list manager workfile from ^TMP("PXRMEXTMP" (see ^PXRMEXLB)
+DISP(VIEW) ;
+ N OLEV,ODSEQ
+ K ^TMP("PXRMEXLD",$J)
+ K PXRMEXRP
+ K ^TMP($J,"PXRMEXREP")
+ N DDATA,DDLG,DEND,DREP,DSTRT,IND,JND,NLINE,NSEL
+ S NLINE=0,NSEL=0,VALMBCK="R",VALMCNT=NLINE
+ S DDLG=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) Q:DDLG=""
+ ;
+ ;Save reminder dialog
+ S DDATA=^TMP("PXRMEXTMP",$J,"DLOC",DDLG)
+ S DSTRT=$P(DDATA,U,1),DEND=$P(DDATA,U,2)
+ S IND=$P(DDATA,U,3),JND=$P(DDATA,U,4),DREP=""
+ D DLINE(DDLG,"","")
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;Process componentS
+ D DCMP(DDLG,"")
+ ;Process replacement elements
+ ;I $D(^TMP("PXRMEXTMP",$J,"DREPL"))>0 D DREPL^PXRMEXLC
+ I $D(PXRMEXRP)>0 D DREPL^PXRMEXLC
+ ;Change header
+ I VIEW=0 D CHGCAP^VALM("HEADER2","Dialog Details")
+ I VIEW=1 D CHGCAP^VALM("HEADER2","Dialog Text")
+ I VIEW=2 D CHGCAP^VALM("HEADER2","Dialog Findings")
+ I VIEW=3 D CHGCAP^VALM("HEADER2","Dialog Summary")
+ I VIEW=4 D CHGCAP^VALM("HEADER2","Dialog Usage")
+ ;
+ S VALMCNT=NLINE,^TMP("PXRMEXLD",$J,"VALMCNT")=VALMCNT,VALMBG=1
+ ;
+ K ^TMP($J,"PXRMEXREP"),PXRMEXRP
+ ;Reset protocol
+ D XQORM
+ Q
+ ;
+ ;Update workfile
+DLINE(DNAM,LEV,DSEQ) ;
+ ;Check if standard PXRM prompt
+ N LEVSEQ,TLEV
+ N DPXRM S DPXRM=$$PXRM^PXRMEXID(DNAM)
+ ;
+ ;Ignore PXRM prompts if doing a finding view (DF)
+ I VIEW>1,DPXRM Q
+ ;
+ N DEXIST,DPTX,DTXT,DTYP,EXIST,ITEM,TEMP,SEP
+ S ITEM=""
+ I DPXRM=0 S NSEL=NSEL+1,ITEM=NSEL
+ S NLINE=NLINE+1,SEP=$E(LEV,$L(LEV)),DEXIST=0
+ S LEVSEQ=LEV_DSEQ
+ S TEMP=$J(ITEM,3)_$J("",4)_LEV_DSEQ
+ ;Determine type
+ S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",DNAM))
+ ;Dialog component display
+ I (VIEW'=1) D
+ .I $L(TEMP)<13 S TEMP=TEMP_$J("",12+$L(SEP)-$L(TEMP))_$E(DNAM,1,50)
+ .E  S TEMP=TEMP_" "_$E(DNAM,1,50)
+ I VIEW=1 D
+ .I DTYP]"" S DTXT=$G(^TMP("PXRMEXTMP",$J,"DTXT",DNAM))
+ .I DTYP="" S DTXT=DNAM
+ .I DREP'="" S DTXT=DNAM
+ .I $L(TEMP)<13 S TEMP=TEMP_$J("",12+$L(SEP)-$L(TEMP))_$E(DTXT,1,50)
+ .E  S TEMP=TEMP_" "_$E(DTXT,1,50)
+ ;Check for replacements
+ I $D(^TMP("PXRMEXTMP",$J,"DREPL",DNAM))>0 D
+ .S TEMP=TEMP_"*"
+ .S TLEV=$S($E(LEVSEQ,$L(LEVSEQ))=".":$E(LEVSEQ,1,$L(LEVSEQ)-1),1:LEVSEQ)
+ .S PXRMEXRP(DNAM)=""
+ .;S ^TMP($J,"PXRMEXREP",TLEV,DNAM)=""
+ ;Add Type
+ S TEMP=TEMP_$J("",65-$L(TEMP))_DTYP
+ ;Exists flag
+ I DPXRM=0,$$EXISTS^PXRMEXIU(801.41,DNAM) D
+ .S TEMP=TEMP_$J("",75-$L(TEMP))_"X",DEXIST=1
+ S ^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ;
+ ;Set up selection index
+ S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)="" Q:DPXRM=1
+ ;Store the file number, start and stop line in the exchange file.
+ S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_DSTRT_U_DEND_U_DEXIST_U_IND_U_JND
+ ;Insert additional text lines
+ I VIEW=1,DREP="" D
+ .N DSUB,DTXT,FILENUM
+ .S DSUB=0,FILENUM=8927.1
+ .F  S DSUB=$O(^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)) Q:'DSUB  D
+ ..S DTXT=$G(^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)),NLINE=NLINE+1
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_$E(DTXT,1,50)
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;TIU template changes
+ .I $D(PXRMNMCH(FILENUM)),$D(^TMP("PXRMEXTMP",$J,"DTIU",DNAM)) D
+ ..N TEMP,TNAM,TNNAM
+ ..S TNAM=""
+ ..F  S TNAM=$O(^TMP("PXRMEXTMP",$J,"DTIU",DNAM,TNAM)) Q:TNAM=""  D
+ ...S TNNAM=$G(PXRMNMCH(FILENUM,TNAM)) Q:TNNAM=""
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ...S TEMP=$J("",12+$L(SEP))_"(TIU template "_TNAM_" copied to "_TNNAM_")"
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;Insert finding items
+ I VIEW=2,("element;group"[DTYP),DREP="" D
+ .N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTAB,FTYP,TEMP
+ .;Findings and additional findings
+ .S DSUB=0,FOUND=0
+ .F  S DSUB=$O(^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB)) Q:'DSUB  D
+ ..S FNAME=$G(^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB)) Q:FNAME=""
+ ..S FDATA=$G(^TMP("PXRMEXFND",$J,FNAME))
+ ..S FILENUM=$P(FDATA,U),FTYP=$P(FDATA,U,2) Q:'FILENUM
+ ..S FREP=$G(PXRMNMCH(FILENUM,FNAME)) I FREP=FNAME S FREP=""
+ ..S NLINE=NLINE+1,EXIST=$$EXISTS^PXRMEXIU(FILENUM,FNAME),FOUND=1
+ ..I DSUB=1 S FLIT="Finding: "
+ ..I DSUB>1 S FLIT="Add. Finding: "
+ ..S FLONG=0 I $L(FLIT_FNAME_" ("_FTYP_")")>60 S FLONG=1
+ ..I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
+ ..I FLONG S FNAME=FLIT_FNAME
+ ..S TEMP=$J("",12+$L(SEP))_$E(FNAME,1,60)_$J("",60-$L(FNAME))
+ ..I EXIST S TEMP=TEMP_$J("",75-$L(TEMP))_"X"
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ..I FLONG D
+ ...S NLINE=NLINE+1
+ ...S FTAB=$S(DSUB=1:21,1:26)
+ ...S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ..I FREP'="" D
+ ...S NLINE=NLINE+1
+ ...S FTAB=$S(DSUB=1:21,1:26)
+ ...S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",FTAB)_"(Replaced by "_FREP_")"
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;If no findings
+ .I 'FOUND D
+ ..S NLINE=NLINE+1
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_"Finding: *NONE*"
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;
+ ;Usage screen
+ I VIEW=4,DREP="" D
+ .N DOTHER,DTXT,DTYPE,OTHER,TYPE
+ .D OTHER(DNAM,.DOTHER) Q:'$D(DOTHER)
+ .S OTHER=""
+ .F  S OTHER=$O(DOTHER(OTHER)) Q:OTHER=""  D
+ ..S TYPE=DOTHER(OTHER),NLINE=NLINE+1,DTYPE="REMINDER DIALOG"
+ ..I TYPE="G" S DTYPE="DIALOG GROUP"
+ ..I TYPE="E" S DTYPE="DIALOG ELEMENT"
+ ..S DTXT="USED BY: "_OTHER_" ("_DTYPE_")"
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_DTXT
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ Q
+ ;
+ ;Save details of dialog components for display
+DCMP(DLG,LEV) ;
+ N DDATA,DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND,LAST,LEVSEQ,NUM
+ S DSEQ=0,LAST=0
+ F  S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)) Q:'DSEQ  D
+ .S DDATA=^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)
+ .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ .S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Check if this component has been replaced
+ .S DREP=$G(PXRMNMCH(FILENUM,DNAM)) I DREP=DNAM S DREP=""
+ .;Save line in workfile
+ .S NUM=DSEQ
+ .;S NUM=$S($G(REPL)["R":"."_DSEQ,1:DSEQ)
+ .I +LEV>0,NUM>0,$E(LEV,$L(LEV))'="." S LEV=LEV_"."
+ .D DLINE(DNAM,LEV,NUM) Q:DREP'=""
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM,LEV_DSEQ_".")
+ .;Extra line feed
+ .I LEV="" D
+ ..S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ I $G(REPL)["R" D
+ .S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ .S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ Q
+ ;
+ ;Rebuild string in ascending or descending order
+ORDER(STRING,ORDER) ;
+ N ARRAY,ITEM,CNT
+ F CNT=1:1 S ITEM=$P(STRING,",",CNT) Q:'ITEM  S ARRAY(ITEM)=""
+ K STRING
+ F CNT=1:1 S ITEM=$O(ARRAY(ITEM),ORDER) Q:'ITEM  D
+ .S $P(STRING,",",CNT)=ITEM
+ Q
+ ;
+ ;Check if used by other dialogs
+OTHER(NAME,LIST) ;
+ N DDATA,DIEN,DNAME,DTYP,IEN
+ S IEN=$O(^PXRMD(801.41,"B",NAME,0)) Q:'IEN
+ ;Check if used by other dialogs
+ I '$D(^PXRMD(801.41,"AD",IEN)) Q
+ ;Build list of dialogs using this component
+ S DIEN=0
+ F  S DIEN=$O(^PXRMD(801.41,"AD",IEN,DIEN)) Q:'DIEN  D
+ .S DDATA=$G(^PXRMD(801.41,DIEN,0)) Q:DDATA=""
+ .S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4) Q:DNAME=""
+ .;Include only dialogs that are not part of this reminder dialog
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) Q
+ .S LIST(DNAME)=DTYP
+ Q
+ ;
+ ;Validate sequence numbers
+VALID(STRING) ;
+ N CNT,FOUND,OK
+ S FOUND=0,OK=1
+ F CNT=1:1 S SEL=$P(STRING,",",CNT) Q:'SEL  D
+ .;Invalid selection
+ .I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
+ ..S OK=0 W $C(7),!,SEL_" is not a valid item number." H 2
+ .S FOUND=1
+ Q:OK&FOUND 1
+ Q 0
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT DIALOG",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Action: "
+ Q
+ ;
+XSEL ;PXRM EXCH SELECT DIALOG validation
+ N ALL,CNT,ERR,IEN,IND,PXRMDONE,SELECT,SEL
+ S ALL="",PXRMDONE=0,PXRMBG=$G(VALMBG)
+ ;Invalid selection
+ S SELECT=$P(XQORNOD(0),"=",2) I '$$VALID(SELECT) S VALMBCK="R" Q
+ ;
+ ;Sort the SELECTION into reverse order
+ D ORDER(.SELECT,-1)
+ ;
+ ;Lock the file
+ I '$$LOCK^PXRMEXID S VALMBCK="R" Q
+ ;
+ ;Install dialog component(s)
+ S CNT=0
+ F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL  D  Q:PXRMDONE
+ .D INSCOM^PXRMEXID(SEL,0)
+ ;
+ ;Unlock file
+ D UNLOCK^PXRMEXID
+ ;
+ ;
+ ;Rebuild Workfile
+ D DISP^PXRMEXLD(PXRMMODE)
+ ;
+ ;Refresh
+ S VALMBCK="R" I $D(PXRMBG) S VALMBG=PXRMBG
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m

@@ -1 @@
-PXRMEXLI        ; SLC/PKR - List Manager routines for repository entry install. ;08/08/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;================================================
-INSALL  ;Install all components in a repository entry.
-        N IND,INSTALL
-        ;Initialize the name change storage.
-        K PXRMNMCH
-        S (IND,INSTALL,PXRMDONE)=0
-        F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:(+IND=0)!(PXRMDONE)  D
-        . D INSCOM(IND,.INSTALL)
-        ;
-        ;If anything was installed rebuild the display.
-        I INSTALL D CDISP^PXRMEXLC(PXRMRIEN)
-        ;
-        ;Save the install history in the repository.
-        D SAVHIST^PXRMEXU1
-        Q
-        ;
-        ;================================================
-INSCOM(IND,INSTALL)     ;Install component IND.
-        ;PXRMRIEN is not passed because this is invoked by the ListManger
-        ;action to install a repository entry.
-        N ACTION,ATTR,END,EXISTS,FIELDNUM,FILENUM,IND120,JND120
-        N NEWNAME,NEWPT01,PT01,RTN,START,TEMP,TEMP0
-        S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND)
-        S FILENUM=$P(TEMP,U,1)
-        S EXISTS=$P(TEMP,U,4)
-        ;Dialogs use their own installation screen.
-        I FILENUM=801.41 D  Q
-        . D START^PXRMEXLD
-        . S VALMBCK="R"
-        S IND120=$P(TEMP,U,2)
-        S JND120=$P(TEMP,U,3)
-        S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)
-        S START=$P(TEMP,U,2)
-        S END=$P(TEMP,U,3)
-        S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
-        ;Go to full screen mode.
-        D FULL^VALM1
-        I ((FILENUM=0)!(FILENUM=811.4)),DUZ(0)'="@" D  Q
-        . I FILENUM=0 W !,"Only programmers can install routines."
-        . I FILENUM=811.4 W !,"Only programmers can install Reminder Computed Findings."
-        . H 2
-        . S VALMBCK="R"
-        I FILENUM=0 D
-        . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
-        . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
-        . S ACTION=$$GETRACT^PXRMEXCF(.ATTR,.NEWNAME,.PXRMNMCH,.RTN,EXISTS)
-        .;Save what was done for the installation summary.
-        . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=NEWNAME
-        E  D
-        .;Make sure we have the .01, some files have .001.
-        . S TEMP0=$P(TEMP,";",3)
-        . S FIELDNUM=$P(TEMP0,"~",1)
-        . I FIELDNUM=.001 S TEMP=^PXD(811.8,PXRMRIEN,100,(START+1),0)
-        . S PT01=$P(TEMP,"~",2)
-        . D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
-        . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
-        . S ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS)
-        .;Save what was done for the installation summary.
-        . S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
-        ;If the ACTION is Quit then quit the entire install.
-        I ACTION="Q" S PXRMDONE=1 Q
-        ;If the ACTION is Skip then skip this component.
-        I ACTION="S" S VALMBCK="R" Q
-        ;If the ACTION is rePlace then skip this component.
-        I ACTION="P" S VALMBCK="R" Q
-        ;Install this component.
-        I FILENUM=0 D
-        . S NEWPT01=$G(PXRMNMCH(ATTR("FILE NUMBER"),ATTR("NAME")))
-        . I NEWPT01="" S NEWPT01=ATTR("NAME")
-        . D RTNSAVE^PXRMEXIC(.RTN,NEWPT01)
-        . S INSTALL=1
-        E  D
-        . D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
-        . S INSTALL=1
-        S VALMBCK="R"
-        Q
-        ;
-        ;================================================
-INSSEL  ;Get a list of components to install.
-        N IND,INSTALL,VALMBG,VALMLST,VALMY
-        ;
-        S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLC",$J,"IDX",""),-1)
-        ;
-        ;Get the list to install.
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        ;
-        ;Initialize the name change storage.
-        K PXRMNMCH
-        S (IND,INSTALL)=0
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D INSCOM(IND,.INSTALL)
-        ;
-        ;If anything was installed rebuild the display.
-        I INSTALL D CDISP^PXRMEXLC(PXRMRIEN)
-        ;
-        ;Save the install history in the repository.
-        D SAVHIST^PXRMEXU1
-        Q
-        ;
-        ;================================================
-INSTALL ;Install the repository entry PXRMRIEN.
-        N IEN,IND,VALMY
-        ;Make sure the component list exists for this entry. PXRMRIEN is
-        ;set in INSTALL^PXRMEXLR.
-        I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN)
-        I PXRMRIEN=-1 Q
-        K ^TMP("PXRMEXIA",$J),^TMP("PXRMEXIAD",$J)
-        ;Set the install date and time and type.
-        S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
-        S ^TMP("PXRMEXIA",$J,"TYPE")="INTERACTIVE"
-        ;Format the component list for display.
-        D CDISP^PXRMEXLC(PXRMRIEN)
-        S VALMCNT=$O(^TMP("PXRMEXLC",$J,"IDX"),-1)
-        S VALMBCK="R"
-        D XQORM
-        Q
-        ;
-        ;================================================
-        ;Exit action added to PXRM EXCH INSTALL MENU
-PEXIT   ;PXRM EXCH INSTALL MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-        ;================================================
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT COMPONENT",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Action: "
-        Q
-        ;
-        ;================================================
-XSEL    ;PXRM EXCH SELECT COMPONENT validation
-        N CNT,SELECT,SEL,PXRMDONE
-        S SELECT=$P(XQORNOD(0),"=",2)
-        I '$$VALID^PXRMEXLD(SELECT) S VALMBCK="R" Q
-        ;
-        ;Sort selections into ascending sequence order
-        D ORDER^PXRMEXLC(.SELECT,1)
-        ;
-        K ^TMP("PXRMEXIA",$J),^TMP("PXRMEXIAD",$J)
-        ;Set the install date and time and type.
-        S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
-        S ^TMP("PXRMEXIA",$J,"TYPE")="INTERACTIVE"
-        ;
-        ;Install selected component
-        N INSTALL
-        S INSTALL=0,CNT=0,PXRMDONE=0
-        F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL  D  Q:PXRMDONE
-        . D INSCOM(SEL,.INSTALL)
-        ;
-        ;If anything was installed rebuild the display.
-        I INSTALL D CDISP^PXRMEXLC(PXRMRIEN)
-        ;
-        ;Save the install history in the repository.
-        D SAVHIST^PXRMEXU1
-        ;
-        ;Clear any renames made in the last session
-        K PXRMNMCH
-        Q
+PXRMEXLI ; SLC/PKR - List Manager routines for repository entry install. ;01/10/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;================================================
+INSALL ;Install all components in a repository entry.
+ N IND,INSTALL
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;Initialize the name change storage.
+ K PXRMNMCH
+ S (IND,INSTALL,PXRMDONE)=0
+ F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:(+IND=0)!(PXRMDONE)  D
+ . D INSCOM(IND,.INSTALL)
+ ;
+ ;If anything was installed rebuild the display.
+ I INSTALL D CDISP^PXRMEXLC(PXRMRIEN)
+ ;
+ ;Save the install history in the repository.
+ D SAVHIST^PXRMEXU1
+ Q
+ ;
+ ;================================================
+INSCOM(IND,INSTALL) ;Install component IND.
+ ;PXRMRIEN is not passed because this is invoked by the ListManger
+ ;action to install a repository entry.
+ N ACTION,ATTR,END,EXISTS,FIELDNUM,FILENUM,IND120,JND120
+ N NEWNAME,NEWPT01,PT01,RTN,START,TEMP,TEMP0
+ S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND)
+ S FILENUM=$P(TEMP,U,1)
+ S EXISTS=$P(TEMP,U,4)
+ ;Dialogs use their own installation screen.
+ I FILENUM=801.41 D  Q
+ . D START^PXRMEXLD
+ . S VALMBCK="R"
+ S IND120=$P(TEMP,U,2)
+ S JND120=$P(TEMP,U,3)
+ S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)
+ S START=$P(TEMP,U,2)
+ S END=$P(TEMP,U,3)
+ S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
+ ;Go to full screen mode.
+ D FULL^VALM1
+ I ((FILENUM=0)!(FILENUM=811.4)),DUZ(0)'="@" D  Q
+ . I FILENUM=0 W !,"Only programmers can install routines."
+ . I FILENUM=811.4 W !,"Only programmers can install Reminder Computed Findings."
+ . H 2
+ . S VALMBCK="R"
+ I FILENUM=0 D
+ . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
+ . S ACTION=$$GETRACT^PXRMEXCF(.ATTR,.NEWNAME,.PXRMNMCH,.RTN,EXISTS)
+ .;Save what was done for the installation summary.
+ . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=NEWNAME
+ E  D
+ .;Make sure we have the .01, some files have .001.
+ . S TEMP0=$P(TEMP,";",3)
+ . S FIELDNUM=$P(TEMP0,"~",1)
+ . I FIELDNUM=.001 S TEMP=^PXD(811.8,PXRMRIEN,100,(START+1),0)
+ . S PT01=$P(TEMP,"~",2)
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM)
+ . S ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS)
+ .;Save what was done for the installation summary.
+ . S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
+ ;If the ACTION is Quit then quit the entire install.
+ I ACTION="Q" S PXRMDONE=1 Q
+ ;If the ACTION is Skip then skip this component.
+ I ACTION="S" S VALMBCK="R" Q
+ ;If the ACTION is rePlace then skip this component.
+ I ACTION="P" S VALMBCK="R" Q
+ ;Install this component.
+ I FILENUM=0 D
+ . S NEWPT01=$G(PXRMNMCH(ATTR("FILE NUMBER"),ATTR("NAME")))
+ . I NEWPT01="" S NEWPT01=ATTR("NAME")
+ . D RTNSAVE^PXRMEXIC(.RTN,NEWPT01)
+ . S INSTALL=1
+ E  D
+ . D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
+ . S INSTALL=1
+ S VALMBCK="R"
+ Q
+ ;
+ ;================================================
+INSSEL ;Get a list of components to install.
+ N IND,INSTALL,VALMBG,VALMLST,VALMY
+ ;
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLC",$J,"IDX",""),-1)
+ ;
+ ;Get the list to install.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
+ ;Initialize the name change storage.
+ K PXRMNMCH
+ S (IND,INSTALL)=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .D INSCOM(IND,.INSTALL)
+ ;
+ ;If anything was installed rebuild the display.
+ I INSTALL D CDISP^PXRMEXLC(PXRMRIEN)
+ ;
+ ;Save the install history in the repository.
+ D SAVHIST^PXRMEXU1
+ Q
+ ;
+ ;================================================
+INSTALL ;Install the repository entry PXRMRIEN.
+ N IEN,IND,VALMY
+ ;Make sure the component list exists for this entry. PXRMRIEN is
+ ;set in INSTALL^PXRMEXLR.
+ I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN)
+ I PXRMRIEN=-1 Q
+ ;Format the component list for display.
+ D CDISP^PXRMEXLC(PXRMRIEN)
+ S VALMCNT=$O(^TMP("PXRMEXLC",$J,"IDX"),-1)
+ S VALMBCK="R"
+ D XQORM
+ Q
+ ;
+ ;Exit action added to PXRM EXCH INSTALL MENU
+PEXIT ;PXRM EXCH INSTALL MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT COMPONENT",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Action: "
+ Q
+ ;
+XSEL ;PXRM EXCH SELECT COMPONENT validation
+ N CNT,SELECT,SEL,PXRMDONE
+ S SELECT=$P(XQORNOD(0),"=",2)
+ I '$$VALID^PXRMEXLD(SELECT) S VALMBCK="R" Q
+ ;
+ ;Sort selections into ascending sequence order
+ D ORDER^PXRMEXLD(.SELECT,1)
+ ;
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
+ ;Install selected component
+ N INSTALL
+ S INSTALL=0,CNT=0,PXRMDONE=0
+ F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL  D  Q:PXRMDONE
+ . D INSCOM(SEL,.INSTALL)
+ ;
+ ;If anything was installed rebuild the display.
+ I INSTALL D CDISP^PXRMEXLC(PXRMRIEN)
+ ;
+ ;Save the install history in the repository.
+ D SAVHIST^PXRMEXU1
+ ;
+ ;Clear any renames made in the last session
+ K PXRMNMCH
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m

@@ -1 @@
-PXRMEXLM        ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;10/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=====================================================
-CRE     ;Create a packed reminder and store it in the repository.
-        N RTP,SUCCESS,TMPIND
-        K VALMHDR
-        S RTP=$$GETREM^PXRMEXPU("pack")
-        I +RTP'>0 D  Q
-        . S VALMHDR(1)="No reminder selected!"
-        . S VALMBCK="R"
-        S TMPIND="PXRMEXPR"
-        D PACK^PXRMEXPR(RTP,TMPIND)
-        D STOREPR^PXRMEXU2(.SUCCESS,RTP,TMPIND,"REMINDER")
-        I SUCCESS D
-        . S VALMHDR(1)="Packed reminder for "_$P(RTP,U,2)
-        . S VALMHDR(2)="was saved in Exchange File."
-        . D BLDLIST^PXRMEXLC(1)
-        E  D
-        . S VALMHDR(1)="Creation of packed reminder for "_$P(RTP,U,2)
-        . S VALMHDR(2)="failed; it was not saved!"
-        S VALMBCK="R"
-        Q
-        ;
-        ;=====================================================
-DEFINQ  ;Reminder definition inquiry.
-        N GBL,IEN,PXRMROOT,VALMCNT
-        S GBL="^TMP(""PXRMRINQ"",$J)"
-        S GBL=$NA(@GBL)
-        S PXRMROOT="^PXD(811.9,"
-        S IEN=$$SELECT^PXRMINQ(PXRMROOT,"Select Reminder Definition: ","")
-        S IEN=$P(IEN,U,1)
-        I IEN=-1 S VALMBCK="R" Q
-        K ^TMP("PXRMRINQ",$J)
-        D REMVAR^PXRMINQ(GBL,IEN)
-        S VALMCNT=$O(^TMP("PXRMRINQ",$J,""),-1)
-        D EN^VALM("PXRM EX DEFINITION INQUIRY")
-        K ^TMP("PXRMRINQ",$J)
-        S VALMBCK="R"
-        Q
-        ;
-        ;=====================================================
-ENTRY   ;Entry code
-        D BLDLIST^PXRMEXLC(0)
-        D XQORM
-        Q
-        ;
-        ;=====================================================
-EXIT    ;Exit code
-        K ^TMP("PXRMEXDH",$J)
-        K ^TMP("PXRMEXHF",$J)
-        K ^TMP("PXRMEXFND",$J)
-        K ^TMP("PXRMEXIA",$J)
-        K ^TMP("PXRMEXIAD",$J)
-        K ^TMP("PXRMEXID",$J)
-        K ^TMP("PXRMEXIH",$J)
-        K ^TMP("PXRMEXLC",$J)
-        K ^TMP("PXRMEXLD",$J)
-        K ^TMP("PXRMEXLHF",$J)
-        K ^TMP("PXRMEXLMM",$J)
-        K ^TMP("PXRMEXLR",$J)
-        K ^TMP("PXRMEXMH",$J)
-        K ^TMP("PXRMEXMM",$J)
-        K ^TMP("PXRMEXRI",$J)
-        K ^TMP("PXRMEXTMP",$J)
-        K ^TMP("PXRMEXTXT",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="Q"
-        Q
-        ;
-        ;=====================================================
-HDR     ; Header code
-        S VALMHDR(1)="Exchange File Entries."
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-        ;=====================================================
-HELP    ;Help code
-        ;The following variables have to be newed so that when we return
-        ;from the help display they will be defined.
-        N ORU,ORUPRMT,XQORM
-        D EN^VALM("PXRM EX MAIN HELP")
-        Q
-        ;
-        ;=====================================================
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-        ;=====================================================
-LDHF    ;Load a host file into the repository.
-        N IND,FILE,PATH,RBL,SUCCESS,TEMP
-        ;Select the host file to load.
-        D CLEAR^VALM1
-        S TEMP=$$GETEHF^PXRMEXHF
-        I TEMP="" S VALMBCK="R" Q
-        S PATH=$P(TEMP,U,1)
-        S FILE=$P(TEMP,U,2)
-        D LHF^PXRMEXHF(.SUCCESS,PATH,FILE)
-        S RBL=SUCCESS
-        I SUCCESS D
-        . S VALMHDR(1)="Host file "_PATH_FILE_" successfully loaded."
-        E  D
-        . S VALMHDR(1)="There were problems loading host file "_PATH_FILE_"."
-        . S TEMP=""
-        . S IND=""
-        . F  S IND=$O(SUCCESS(IND)) Q:+IND=0  D
-        .. I SUCCESS(IND) S RBL=1 Q
-        .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND
-        .. E  S TEMP=TEMP_IND_", "
-        . S VALMHDR(2)="Entries with problems were "_TEMP_"."
-        ;Rebuild the list for display.
-        D BLDLIST^PXRMEXLC(RBL)
-        S VALMBCK="R"
-        Q
-        ;
-        ;=====================================================
-LDMM    ;Load a MailMan message into the repository.
-        N IND,RBL,TEMP,XMZ
-        ;Select the MailMan message to load.
-        D CLEAR^VALM1
-        S XMZ=$$GETMESSN^PXRMEXMM
-        I XMZ=-1 W !,"No packed reminder definitions selected/found!" H 2
-        I +XMZ'>0 S VALMBCK="R" Q
-        D LMM^PXRMEXMM(.SUCCESS,XMZ)
-        S RBL=SUCCESS
-        I SUCCESS D
-        . S VALMHDR(1)="MailMan message "_XMZ_" successfully loaded."
-        .;Rebuild the list for display.
-        . D BLDLIST^PXRMEXLC(1)
-        E  D
-        . S VALMHDR(1)="There were problems loading MailMan message "_XMZ_"."
-        . S TEMP=""
-        . S IND=""
-        . F  S IND=$O(SUCCESS(IND)) Q:+IND=0  D
-        .. I SUCCESS(IND) S RBL=1 Q
-        .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND
-        .. E  S TEMP=TEMP_IND_", "
-        . S VALMHDR(2)="Entries with problems were "_TEMP_"."
-        ;Rebuild the list for display.
-        D BLDLIST^PXRMEXLC(RBL)
-        S VALMBCK="R"
-        Q
-        ;
-        ;=====================================================
-LRDEF   ;List the name and print name of all reminder definitions.
-        N VALMCNT
-        I $D(^TMP("PXRMEXLD",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLD",$J,"VALMCNT")
-        E  D
-        . N ARO,DEFLIST
-        . S ARO=$$QUERYAO^PXRMLIST
-        . S ^TMP("PXRMEXLD",$J,"ARO")=ARO
-        . D RDEF^PXRMLIST(.DEFLIST,ARO)
-        . M ^TMP("PXRMEXLD",$J)=DEFLIST
-        . S VALMCNT=DEFLIST("VALMCNT")
-        I '$G(^TMP("PXRMEXLD",$J,"ARO")) D CHGCAP^VALM("INACTIVE","Inactive")
-        D EN^VALM("PXRM EX REMINDER LIST")
-        Q
-        ;
-        ;=====================================================
-PEXIT   ;PXRM EXCH MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-        ;=====================================================
-START   ;Main entry point for PXRM EXCHANGE
-        N PXRMDONE,PXRMNMCH
-        ;PXRMDONE is set to true if the user enters an action of Quit.
-        S PXRMDONE=0
-        ;PXRMNMCH is used to store name change information. If a finding
-        ;is copied to a new name or is replaced by another finding the
-        ;information is stored here. It is used when installing definitions
-        ;or dialogs so they use the new or replaced finding.
-        N VALMBCK,VALMSG,X,XMZ
-        S X="IORESET"
-        D ENDR^%ZISS
-        D EN^VALM("PXRM EX REMINDER EXCHANGE")
-        W IORESET
-        D KILL^%ZISS
-        Q
-        ;
-        ;=====================================================
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT ENTRY",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Action: "
-        Q
-        ;
-        ;=====================================================
-XSEL    ;PXRM EXCH SELECT COMPONENT validation
-        N SEL,PXRMRIEN
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;
-        ;Get the repository ien.
-        S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",SEL)
-        ;
-        ;Full screen mode
-        D FULL^VALM1
-        ;
-        ;Option to Install, Delete or Install History
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y
-        S DIR(0)="SBM"_U_"IFE:Install Exchange File Entry;"
-        S DIR(0)=DIR(0)_"DFE:Delete Exchange File Entry;"
-        S DIR(0)=DIR(0)_"IH:Installation History;"
-        S DIR("A")="Select Action: "
-        S DIR("B")="IFE"
-        S DIR("?")="Select from the codes displayed. For detailed help type ??"
-        S DIR("??")=U_"D HLP^PXRMEXIX(3)"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) S VALMBCK="R" Q
-        I $D(DTOUT)!$D(DUOUT) S VALMBCK="R" Q
-        S OPTION=Y
-        ;
-        ;Install
-        I OPTION="IFE" D
-        .D EN^VALM("PXRM EX LIST COMPONENTS")
-        .K ^TMP("PXRMEXLC",$J)
-        ;
-        I OPTION="DFE" D
-        .N COUNT,DELLIST,IEN,IND,RELIST,VALMY
-        .S DELLIST(PXRMRIEN)=""
-        .D DELETE^PXRMEXU1(.DELLIST)
-        .;Rebuild the list for List Manager to display.
-        .K ^TMP("PXRMEXLR",$J)
-        .D REXL^PXRMLIST("PXRMEXLR")
-        .S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
-        .S VALMHDR(1)="Deleted 1 exchange file entry",VALMHDR(2)=" ",VALMBCK="R"
-        ;
-        I OPTION="IH" D START^PXRMEXIH
-        ;
-        S VALMBCK="R"
-        Q
+PXRMEXLM ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=====================================================
+CRE ;Create a packed reminder and store it in the repository.
+ N RTP,SUCCESS,TMPIND
+ K VALMHDR
+ S RTP=$$GETREM^PXRMEXPU("pack")
+ I +RTP'>0 D  Q
+ . S VALMHDR(1)="No reminder selected!"
+ . S VALMBCK="R"
+ S TMPIND="PXRMEXPR"
+ D PACK^PXRMEXPR(RTP,TMPIND)
+ D STOREPR^PXRMEXU2(.SUCCESS,RTP,TMPIND,"REMINDER")
+ I SUCCESS D
+ . S VALMHDR(1)="Packed reminder for "_$P(RTP,U,2)
+ . S VALMHDR(2)="was saved in Exchange File."
+ . D BLDLIST^PXRMEXLC(1)
+ E  D
+ . S VALMHDR(1)="Creation of packed reminder for "_$P(RTP,U,2)
+ . S VALMHDR(2)="failed; it was not saved!"
+ S VALMBCK="R"
+ Q
+ ;
+ ;=====================================================
+DEFINQ ;Reminder definition inquiry.
+ N GBL,IEN,PXRMROOT,VALMCNT
+ S GBL="^TMP(""PXRMRINQ"",$J)"
+ S GBL=$NA(@GBL)
+ S PXRMROOT="^PXD(811.9,"
+ S IEN=$$SELECT^PXRMINQ(PXRMROOT,"Select Reminder Definition: ","")
+ S IEN=$P(IEN,U,1)
+ I IEN=-1 S VALMBCK="R" Q
+ K ^TMP("PXRMRINQ",$J)
+ D REMVAR^PXRMINQ(GBL,IEN)
+ S VALMCNT=$O(^TMP("PXRMRINQ",$J,""),-1)
+ D EN^VALM("PXRM EX DEFINITION INQUIRY")
+ K ^TMP("PXRMRINQ",$J)
+ S VALMBCK="R"
+ Q
+ ;
+ ;=====================================================
+EN ;Main entry point for PXRM EXCHANGE
+ N PXRMDONE,PXRMNMCH
+ ;PXRMDONE is set to true if the user enters an action of Quit.
+ S PXRMDONE=0
+ ;PXRMNMCH is used to store name change information. If a finding
+ ;is copied to a new name or is replaced by another finding the
+ ;information is stored here. It is used when installing definitions
+ ;or dialogs so they use the new or replaced finding.
+ N VALMBCK,VALMSG,X,XMZ
+ S X="IORESET"
+ D ENDR^%ZISS
+ D BLDLIST^PXRMEXLC(0)
+ D EN^VALM("PXRM EX REMINDER EXCHANGE")
+ W IORESET
+ D KILL^%ZISS
+ Q
+ ;
+ ;=====================================================
+ENTRY ;Entry code
+ D XQORM
+ Q
+ ;
+ ;=====================================================
+EXIT ;Exit code
+ K ^TMP("PXRMEXDH",$J)
+ K ^TMP("PXRMEXHF",$J)
+ K ^TMP("PXRMEXFND",$J)
+ K ^TMP("PXRMEXIA",$J)
+ K ^TMP("PXRMEXID",$J)
+ K ^TMP("PXRMEXIH",$J)
+ K ^TMP("PXRMEXLC",$J)
+ K ^TMP("PXRMEXLD",$J)
+ K ^TMP("PXRMEXLHF",$J)
+ K ^TMP("PXRMEXLMM",$J)
+ K ^TMP("PXRMEXLR",$J)
+ K ^TMP("PXRMEXMH",$J)
+ K ^TMP("PXRMEXMM",$J)
+ K ^TMP("PXRMEXRI",$J)
+ K ^TMP("PXRMEXTMP",$J)
+ K ^TMP("PXRMEXTXT",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
+ ;=====================================================
+HDR ; Header code
+ S VALMHDR(1)="Exchange File Entries."
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+ ;=====================================================
+HELP ;Help code
+ ;The following variables have to be newed so that when we return
+ ;from the help display they will be defined.
+ N ORU,ORUPRMT,XQORM
+ D EN^VALM("PXRM EX MAIN HELP")
+ Q
+ ;
+ ;=====================================================
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+ ;=====================================================
+LDHF ;Load a host file into the repository.
+ N IND,FILE,PATH,RBL,SUCCESS,TEMP
+ ;Select the host file to load.
+ D CLEAR^VALM1
+ S TEMP=$$GETEHF^PXRMEXHF
+ I TEMP="" S VALMBCK="R" Q
+ S PATH=$P(TEMP,U,1)
+ S FILE=$P(TEMP,U,2)
+ D LHF^PXRMEXHF(.SUCCESS,PATH,FILE)
+ S RBL=SUCCESS
+ I SUCCESS D
+ . S VALMHDR(1)="Host file "_PATH_FILE_" successfully loaded."
+ E  D
+ . S VALMHDR(1)="There were problems loading host file "_PATH_FILE_"."
+ . S TEMP=""
+ . S IND=""
+ . F  S IND=$O(SUCCESS(IND)) Q:+IND=0  D
+ .. I SUCCESS(IND) S RBL=1 Q
+ .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND
+ .. E  S TEMP=TEMP_IND_", "
+ . S VALMHDR(2)="Entries with problems were "_TEMP_"."
+ ;Rebuild the list for display.
+ D BLDLIST^PXRMEXLC(RBL)
+ S VALMBCK="R"
+ Q
+ ;
+ ;=====================================================
+LDMM ;Load a MailMan message into the repository.
+ N IND,RBL,TEMP,XMZ
+ ;Select the MailMan message to load.
+ D CLEAR^VALM1
+ S XMZ=$$GETMESSN^PXRMEXMM
+ I XMZ=-1 W !,"No packed reminder definitions selected/found!" H 2
+ I +XMZ'>0 S VALMBCK="R" Q
+ D LMM^PXRMEXMM(.SUCCESS,XMZ)
+ S RBL=SUCCESS
+ I SUCCESS D
+ . S VALMHDR(1)="MailMan message "_XMZ_" successfully loaded."
+ .;Rebuild the list for display.
+ . D BLDLIST^PXRMEXLC(1)
+ E  D
+ . S VALMHDR(1)="There were problems loading MailMan message "_XMZ_"."
+ . S TEMP=""
+ . S IND=""
+ . F  S IND=$O(SUCCESS(IND)) Q:+IND=0  D
+ .. I SUCCESS(IND) S RBL=1 Q
+ .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND
+ .. E  S TEMP=TEMP_IND_", "
+ . S VALMHDR(2)="Entries with problems were "_TEMP_"."
+ ;Rebuild the list for display.
+ D BLDLIST^PXRMEXLC(RBL)
+ S VALMBCK="R"
+ Q
+ ;
+ ;=====================================================
+LRDEF ;List the name and print name of all reminder definitions.
+ N VALMCNT
+ I $D(^TMP("PXRMEXLD",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLD",$J,"VALMCNT")
+ E  D
+ . N ARO,DEFLIST
+ . S ARO=$$QUERYAO^PXRMLIST
+ . S ^TMP("PXRMEXLD",$J,"ARO")=ARO
+ . D RDEF^PXRMLIST(.DEFLIST,ARO)
+ . M ^TMP("PXRMEXLD",$J)=DEFLIST
+ . S VALMCNT=DEFLIST("VALMCNT")
+ I '$G(^TMP("PXRMEXLD",$J,"ARO")) D CHGCAP^VALM("INACTIVE","Inactive")
+ D EN^VALM("PXRM EX REMINDER LIST")
+ Q
+ ;
+ ;=====================================================
+PEXIT ;PXRM EXCH MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Action: "
+ Q
+ ;
+XSEL ;PXRM EXCH SELECT COMPONENT validation
+ N SEL,PXRMRIEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the repository ien.
+ S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",SEL,SEL)
+ ;
+ ;Full screen mode
+ D FULL^VALM1
+ ;
+ ;Option to Install, Delete or Install History
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y
+ S DIR(0)="SBM"_U_"IFE:Install Exchange File Entry;"
+ S DIR(0)=DIR(0)_"DFE:Delete Exchange File Entry;"
+ S DIR(0)=DIR(0)_"IH:Installation History;"
+ S DIR("A")="Select Action: "
+ S DIR("B")="IFE"
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ S DIR("??")=U_"D HLP^PXRMEXIX(3)"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) S VALMBCK="R" Q
+ I $D(DTOUT)!$D(DUOUT) S VALMBCK="R" Q
+ S OPTION=Y
+ ;
+ ;Install
+ I OPTION="IFE" D
+ .D EN^VALM("PXRM EX LIST COMPONENTS")
+ .K ^TMP("PXRMEXLC",$J)
+ ;
+ I OPTION="DFE" D
+ .N COUNT,DELLIST,IEN,IND,RELIST,VALMY
+ .S DELLIST(PXRMRIEN)=""
+ .D DELETE^PXRMEXU1(.DELLIST)
+ .;Rebuild the list for List Manager to display.
+ .K ^TMP("PXRMEXLR",$J)
+ .D RE^PXRMLIST(.RELIST,.IEN)
+ .M ^TMP("PXRMEXLR",$J)=RELIST
+ .S VALMCNT=RELIST("VALMCNT")
+ .F IND=1:1:VALMCNT D
+ ..S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
+ .;
+ .S VALMHDR(1)="Deleted 1 exchange file entry",VALMHDR(2)=" ",VALMBCK="R"
+ ;
+ I OPTION="IH" D
+ .N HISLIST,VALMCNT
+ .S HISLIST(SEL)=""
+ .D HISTLIST^PXRMEXLC(.HISLIST,.VALMCNT)
+ .D EN^VALM("PXRM EX INSTALLATION HISTORY")
+ .K ^TMP("PXRMEXIH",$J)
+ ;
+ S VALMBCK="R"
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m

@@ -1 @@
-PXRMEXLR        ; SLC/PKR/PJH - List Manager routines for existing repository entries. ;07/30/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;==================================================
-CHF     ;Create a host file containing repository entries.
-        N IND,FILE,LENH2,PATH,SUCCESS,TEMP,VALMY
-        ;Get the list to store.
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        ;Get the host file to use.
-        D CLEAR^VALM1
-        S TEMP=$$GETHFS^PXRMEXHF
-        I TEMP=0 S VALMBCK="R" Q
-        S PATH=$P(TEMP,U,1)
-        S FILE=$P(TEMP,U,2)
-        D CHF^PXRMEXHF(.SUCCESS,.VALMY,PATH,FILE)
-        S VALMHDR(1)="Successfully stored entries"
-        S VALMHDR(2)="Failed to store entries"
-        S LENH2=$L(VALMHDR(2))
-        S IND=""
-        F  S IND=$O(SUCCESS(IND)) Q:+IND=0  D
-        . I SUCCESS(IND) S VALMHDR(1)=VALMHDR(1)_" "_IND
-        . E  S VALMHDR(2)=VALMHDR(2)_" "_IND
-        I $L(VALMHDR(2))=LENH2 K VALMHDR(2)
-        S VALMBCK="R"
-        Q
-        ;
-        ;==================================================
-CMM     ;Create a MailMan message containing packed reminders.
-        N SUCCESS,TEMP,VALMY
-        ;Get the list to store.
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        ;Get a new message number to store the entries in.
-        D CMM^PXRMEXMM(.SUCCESS,.VALMY)
-        I $D(SUCCESS("XMZ")) S VALMHDR(1)="Successfully stored entries in message "_SUCCESS("XMZ")_"."
-        E  S VALMHDR(1)="Failed to store entries"
-        S VALMBCK="R"
-        Q
-        ;
-        ;==================================================
-DELETE  ;Get a list of repository entries and delete them.
-        N COUNT,DELLIST,IEN,IND,RELIST,VALMY
-        ;Get the list to delete.
-        D MIENLIST(.DELLIST)
-        S COUNT=+$G(DELLIST("COUNT"))
-        I COUNT=0 Q
-        D DELETE^PXRMEXU1(.DELLIST)
-        ;Rebuild the list for List Manager to display.
-        K ^TMP("PXRMEXLR",$J)
-        D REXL^PXRMLIST("PXRMEXLR")
-        ;
-        S VALMHDR(1)="Deleted "_DELLIST("COUNT")_" Exchange File"
-        I COUNT>1 S VALMHDR(1)=VALMHDR(1)_" entries."
-        I COUNT=1 S VALMHDR(1)=VALMHDR(1)_" entry."
-        I COUNT=0 S VALMHDR(1)="No entries selected."
-        S VALMHDR(2)=" "
-        S VALMBCK="R"
-        Q
-        ;
-        ;==================================================
-EXIT    ; Exit code
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="R"
-        K ^TMP("PXRMEXLR",$J)
-        Q
-        ;
-        ;==================================================
-INSTALL ;Get a list of repository entries and install them.
-        N IND,PXRMRIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        ;PXRMDONE is newed in PXRMEXLM
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the repository ien.
-        . S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",IND)
-        .;The list template calls INSTALL^PXRMEXLI
-        . D EN^VALM("PXRM EX LIST COMPONENTS")
-        . K ^TMP("PXRMEXLC",$J)
-        Q
-        ;
-        ;==================================================
-HDR     ; Header code
-        S VALMHDR(1)=""
-        D CHGCAP^VALM("RNAME","Reminder Name")
-        D CHGCAP^VALM("PNAME","Date Loaded")
-        Q
-        ;
-        ;==================================================
-HELP    ; Help code
-        S X="?" D DISP^XQORM1 W !!
-        Q
-        ;
-        ;==================================================
-MIENLIST(LIST)  ;Get a list of List Manager repository entries and turn it
-        ;into iens.
-        N COUNT,IEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S COUNT=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:+IND=0  D
-        . S COUNT=COUNT+1
-        . ;S IEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
-        . S IEN=^TMP("PXRMEXLR",$J,"SEL",IND)
-        . S LIST(IEN)=""
-        S LIST("COUNT")=COUNT
-        Q
-        ;
-        ;==================================================
-PEXIT   ;PXRM EXCH INSTALLATION MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
+PXRMEXLR ; SLC/PKR/PJH - List Manager routines for existing repository entries. ;01/10/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;==================================================
+CHF ;Create a host file containing repository entries.
+ N IND,FILE,LENH2,PATH,SUCCESS,TEMP,VALMY
+ ;Get the list to store.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;Get the host file to use.
+ D CLEAR^VALM1
+ S TEMP=$$GETHFS^PXRMEXHF
+ I TEMP=0 S VALMBCK="R" Q
+ S PATH=$P(TEMP,U,1)
+ S FILE=$P(TEMP,U,2)
+ D CHF^PXRMEXHF(.SUCCESS,.VALMY,PATH,FILE)
+ S VALMHDR(1)="Successfully stored entries"
+ S VALMHDR(2)="Failed to store entries"
+ S LENH2=$L(VALMHDR(2))
+ S IND=""
+ F  S IND=$O(SUCCESS(IND)) Q:+IND=0  D
+ . I SUCCESS(IND) S VALMHDR(1)=VALMHDR(1)_" "_IND
+ . E  S VALMHDR(2)=VALMHDR(2)_" "_IND
+ I $L(VALMHDR(2))=LENH2 K VALMHDR(2)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+CMM ;Create a MailMan message containing packed reminders.
+ N SUCCESS,TEMP,VALMY
+ ;Get the list to store.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;Get a new message number to store the entries in.
+ D CMM^PXRMEXMM(.SUCCESS,.VALMY)
+ I $D(SUCCESS("XMZ")) S VALMHDR(1)="Successfully stored entries in message "_SUCCESS("XMZ")_"."
+ E  S VALMHDR(1)="Failed to store entries"
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+DELETE ;Get a list of repository entries and delete them.
+ N COUNT,DELLIST,IEN,IND,RELIST,VALMY
+ ;Get the list to delete.
+ D MIENLIST(.DELLIST)
+ S COUNT=+$G(DELLIST("COUNT"))
+ I COUNT=0 Q
+ D DELETE^PXRMEXU1(.DELLIST)
+ ;Rebuild the list for List Manager to display.
+ K ^TMP("PXRMEXLR",$J)
+ D RE^PXRMLIST(.RELIST,.IEN)
+ M ^TMP("PXRMEXLR",$J)=RELIST
+ S VALMCNT=RELIST("VALMCNT")
+ F IND=1:1:VALMCNT S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
+ ;
+ S VALMHDR(1)="Deleted "_DELLIST("COUNT")_" Exchange File"
+ I COUNT>1 S VALMHDR(1)=VALMHDR(1)_" entries."
+ I COUNT=1 S VALMHDR(1)=VALMHDR(1)_" entry."
+ I COUNT=0 S VALMHDR(1)="No entries selected."
+ S VALMHDR(2)=" "
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+DELHIST ;Get a list of repository installation entries and delete them.
+ ;Save the original list, it contains the selected repository entries.
+ N VALMYO
+ M VALMYO=VALMY
+ N IHIND,IND,RIEN,TEMP,VALMY
+ N VALMBG,VALMLST
+ ;
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXIH",$J,"IDX",""),-1)
+ ;Get the list to delete.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:IND=""  D
+ . S TEMP=^TMP("PXRMEXIH",$J,"SEL",IND)
+ . S RIEN=$P(TEMP,U,1)
+ . S IHIND=$P(TEMP,U,2)
+ . D DELHIST^PXRMEXU1(RIEN,IHIND)
+ ;Rebuild the display list.
+ D HISTLIST^PXRMEXLC(.VALMYO,.VALMCNT)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+EXIT ; Exit code
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="R"
+ K ^TMP("PXRMEXLR",$J)
+ Q
+ ;
+ ;==================================================
+IH ;Get a list of repository entries and show their installation history.
+ N VALMCNT,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;Build a history list.
+ D HISTLIST^PXRMEXLC(.VALMY,.VALMCNT)
+ D EN^VALM("PXRM EX INSTALLATION HISTORY")
+ K ^TMP("PXRMEXIH",$J)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+INDETAIL ;Output the details of an installation.
+ N VALMBG,VALMCNT,VALMHDR,VALMLST,VALMY
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXIH",$J,"IDX",""),-1)
+ ;Get the list to display.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ D INDISP(.VALMY)
+ Q
+ ;
+ ;==================================================
+INDISP(ARRAY) ;Display details list
+ N ACTION,CMPNT,DI,DP,ENTRY,IHIND,IND,INDEX,JND,KND
+ N NAME,NEWNAME,NLINE,RIEN,TEMP
+ K ^TMP("PXRMEXID",$J)
+ ;If there are no items then quit.
+ I '$D(ARRAY) Q
+ S (IND,NLINE)=0
+ F  S IND=$O(ARRAY(IND)) Q:IND=""  D
+ . S TEMP=^TMP("PXRMEXIH",$J,"SEL",IND)
+ . S RIEN=$P(TEMP,U,1)
+ . S IHIND=$P(TEMP,U,2)
+ . S TEMP=^PXD(811.8,RIEN,0)
+ . S ENTRY=$E($P(TEMP,U,1),1,38)
+ . S ENTRY=$$LJ^XLFSTR(ENTRY,38," ")
+ . S DP=$$FMTE^XLFDT($P(TEMP,U,3),"5Z")
+ . S DI=$$FMTE^XLFDT(^PXD(811.8,RIEN,130,IHIND,0),"5Z")
+ . I NLINE>1 D
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXID",$J,NLINE,0)="------------------------------------------------------------------------------"
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)=ENTRY_" "_DP_"  "_DI
+ .;Write the header line here.
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)="     Component                         Action  New Name"
+ . S CMPNT=""
+ . S JND=0
+ . F  S JND=$O(^PXD(811.8,RIEN,130,IHIND,1,JND)) Q:JND=""  D
+ .. S TEMP=^PXD(811.8,RIEN,130,IHIND,1,JND,0)
+ .. I $P(TEMP,U,2)'=CMPNT D
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=" "
+ ... S CMPNT=$P(TEMP,U,2)
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=CMPNT
+ .. S INDEX=$$RJ^XLFSTR($P(TEMP,U,1),4," ")
+ .. S NAME=$E($P(TEMP,U,3),1,36)
+ .. S NAME=$$LJ^XLFSTR(NAME,36," ")
+ .. S ACTION=$P(TEMP,U,4)
+ .. S NEWNAME=$E($P(TEMP,U,5),1,36)
+ .. S NEWNAME=$$LJ^XLFSTR(NEWNAME,36," ")
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXID",$J,NLINE,0)=INDEX_" "_NAME_" "_ACTION_"    "_NEWNAME
+ ..;If there are Additional Details add them to the display.
+ .. S KND=0
+ .. F  S KND=$O(^PXD(811.8,RIEN,130,IHIND,1,JND,1,KND)) Q:KND=""  D
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=^PXD(811.8,RIEN,130,IHIND,1,JND,1,KND,0)
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)=" "
+ S VALMHDR(1)=^PXD(811.8,RIEN,0)_"  "_^TMP("PXRMEXID",$J,1,0)
+ S VALMCNT=NLINE
+ D EN^VALM("PXRM EX INSTALLATION DETAIL")
+ K ^TMP("PXRMEXID",$J)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+INSTALL ;Get a list of repository entries and install them.
+ N IND,PXRMRIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMEXLM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the repository ien.
+ . S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
+ .;The list template calls INSTALL^PXRMEXLI
+ . D EN^VALM("PXRM EX LIST COMPONENTS")
+ . K ^TMP("PXRMEXLC",$J)
+ Q
+ ;
+ ;==================================================
+HDR ; Header code
+ S VALMHDR(1)=""
+ D CHGCAP^VALM("RNAME","Reminder Name")
+ D CHGCAP^VALM("PNAME","Date Loaded")
+ Q
+ ;
+ ;==================================================
+HELP ; Help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+ ;
+ ;==================================================
+IS ;Get a list of packed reminders and print the installation summary.
+ N VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ Q
+ ;
+ ;==================================================
+MIENLIST(LIST) ;Get a list of List Manager repository entries and turn it
+ ;into iens.
+ N COUNT,IEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S COUNT=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:+IND=0  D
+ . S COUNT=COUNT+1
+ . S IEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
+ . S LIST(IEN)=""
+ S LIST("COUNT")=COUNT
+ Q
+ ;
+ ;==================================================
+PEXIT ;PXRM EXCH INSTALLATION MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+ ;==================================================
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT HISTORY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Action: "
+ Q
+ ;
+ ;==================================================
+XSEL ;PXRM EXCH SELECT HISTORY validation
+ N ARRAY,CNT,SELECT,SEL
+ S SELECT=$P(XQORNOD(0),"=",2)
+ I '$$VALID^PXRMEXLD(SELECT) S VALMBCK="R" Q
+ ;Build array of selected items
+ F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL  D
+ .S ARRAY(SEL)=""
+ ;
+ ;Display Selected Histories
+ D INDISP(.ARRAY)
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m

@@ -1 @@
-PXRMEXPR        ; SLC/PKR/PJH - Routines to create packed reminder definitions. ;12/12/2006
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;===============================================================
-ADDFILE(FLIST,ROOT,FILENAME)    ;Add a file to the list of finding files.
-        N DIC,DO,FILENUM
-        S DIC="^"_ROOT
-        K DO
-        D DO^DIC1
-        S FILENUM=+DO(2)
-        S FILENAME=$P(DO,U,1)
-        S FLIST(FILENAME)=FILENUM
-        Q
-        ;
-        ;===============================================================
-ADDFIND(FLIST,FILENAME,IEN)     ;Add a finding to the list of findings.
-        S FLIST(FILENAME,"F",IEN)=""
-        ;Make sure categories are included for any health factors and they
-        ;come first in the list of health factors.
-        I FILENAME="HEALTH FACTORS" D
-        . N CAT
-        . S CAT=$P(^AUTTHF(IEN,0),U,3)
-        . S FLIST(FILENAME,"C",CAT)=""
-        Q
-        ;
-        ;===============================================================
-BLDSPON(RIEN,FINDLIST,SPONLIST) ;Build the sponsor list.
-        N DIEN,IEN,IND,IND0
-        ;Start with the definition.
-        D GETSPON(811.9,RIEN,.SPONLIST)
-        ;If there is a dialog add it.
-        ;S DIEN=+$P($G(^PXD(811.9,RIEN,51)),U,1)
-        ;I DIEN>0 D GETSPON(801.41,DIEN,.SPONLIST)
-        ;Go through the finding list to find additional sponsors.
-        S IND=""
-        F  S IND=$O(FINDLIST(IND)) Q:IND=""  D
-        . S FILENUM=FINDLIST(IND)
-        . I (FILENUM'<800)&(FILENUM'>811.9) D
-        .. S IND0=""
-        .. F  S IND0=$O(FINDLIST(IND,IND0)) Q:IND0=""  D
-        ... S IEN=""
-        ... F  S IEN=+$O(FINDLIST(IND,IND0,IEN)) Q:IEN=0  D
-        .... D GETSPON(FILENUM,IEN,.SPONLIST)
-        ;Add any associated sponsors to the begining of the list.
-        S IND=""
-        F  S IND=$O(SPONLIST("S",IND)) Q:IND=""  D
-        . S IND0=0
-        . F  S IND0=+$O(^PXRMD(811.6,IND,2,IND0)) Q:IND0=0  D
-        .. S IEN=+^PXRMD(811.6,IND,2,IND0,0)
-        .. S SPONLIST("A",IEN)=""
-        Q
-        ;
-        ;===============================================================
-BLDTEXT(TMPIND) ;Combine the source information and the user's input into the
-        ;"TEXT" array.
-        N IC,IND
-        S (IC,IND)=0
-        F  S IC=$O(^TMP(TMPIND,$J,"SRC",IC)) Q:+IC=0  D
-        . S IND=IND+1
-        . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"SRC",IC)
-        ;
-        S IC=0
-        F  S IC=$O(^TMP(TMPIND,$J,"TXT",1,IC)) Q:+IC=0  D
-        . S IND=IND+1
-        . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"TXT",1,IC,0)
-        Q
-        ;
-        ;===============================================================
-GETDFIND(RIEN,FLIST)    ;Build the list of definition findings.
-        ;FLIST has the format FLIST(FILENAME)=file number, and for each
-        ;finding from the file FLIST(FILENAME,"F",IEN)="". For Health Factors
-        ;category entries are FLIST(FILENAME,"C",IEN)="".
-        N FILENAME,IEN,ROOT
-        S ROOT=""
-        F  S ROOT=$O(^PXD(811.9,RIEN,20,"E",ROOT)) Q:ROOT=""  D
-        . D ADDFILE(.FLIST,ROOT,.FILENAME)
-        . S IEN=0
-        . F  S IEN=$O(^PXD(811.9,RIEN,20,"E",ROOT,IEN)) Q:+IEN=0  D
-        .. D ADDFIND(.FLIST,FILENAME,IEN)
-        Q
-        ;
-        ;===============================================================
-GETSPON(FILENUM,IEN,SPONLIST)   ;Add sponsors to the sponsor list.
-        N ENTRY,ROOT,SPONSOR
-        S ROOT=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
-        S ENTRY=ROOT_IEN_",100)"
-        S ENTRY=$G(@ENTRY)
-        S SPONSOR=$P(ENTRY,U,2)
-        I SPONSOR'="" S SPONLIST("S",SPONSOR)=""
-        Q
-        ;
-        ;===============================================================
-GETTFIND(FLIST) ;If there are any terms in the list of findings go through
-        ;them and add the mapped findings to the list of findings.
-        I '$D(FLIST("REMINDER TERM")) Q
-        N FILENAME,ROOT,TIEN
-        S TIEN=0
-        F  S TIEN=$O(FLIST("REMINDER TERM","F",TIEN)) Q:+TIEN=0  D
-        . S ROOT=""
-        . F  S ROOT=$O(^PXRMD(811.5,TIEN,20,"E",ROOT)) Q:ROOT=""  D
-        .. D ADDFILE(.FLIST,ROOT,.FILENAME)
-        .. S IEN=0
-        .. F  S IEN=$O(^PXRMD(811.5,TIEN,20,"E",ROOT,IEN)) Q:+IEN=0  D
-        ... D ADDFIND(.FLIST,FILENAME,IEN)
-        Q
-        ;
-        ;===============================================================
-GETTEXT(RIEN,TMPIND,INDEX)      ;Let the user input some text.
-        N DIC,DWLW,DWPK
-        ;If this is the description text, load the reminder description as
-        ;the default.
-        S RIEN=+RIEN
-        I RIEN>0 M ^TMP(TMPIND,$J,INDEX,1)=^PXD(811.9,RIEN,1)
-        S DIC="^TMP(TMPIND,$J,"""_INDEX_""",1,"
-        S DWLW=72
-        S DWPK=1
-        D EN^DIWE
-        Q
-        ;
-        ;===============================================================
-PACK(RTP,TMPIND)        ;Create the packed reminder, store it in
-        ;^TMP(TMPIND,$J). TMPIND should be namespaced and set by the caller.
-        ;Save the source information
-        I +RTP'>0 Q
-        K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J)
-        D PUTSRC(RTP,TMPIND)
-        ;
-        ;Have the user input text that describes the reminder.
-        W !,"Enter a description of the reminder you are packing." H 3
-        D GETTEXT(RTP,TMPIND,"DESC")
-        ;
-        ;Have the user input keywords for indexing the reminder.
-        W !,"Enter keywords or phrases to help index the reminder you are packing."
-        W !,"Separate the keywords or phrases on each line with commas." H 3
-        D GETTEXT(0,TMPIND,"KEYWORD")
-        ;
-        ;Combine the source and input text into the "TEXT" array.
-        D BLDTEXT(TMPIND)
-        ;
-        W !,"Packing the reminder ... "
-        ;Build lists of the various reminder components.
-        N CF,IEN,IND0,FINDLIST,FILELIST,FILENAME,FILENUM,DLGLIST
-        N NUMF,NUMR,OBJLIST,RIEN,ROUTINE,RTNLIST
-        N SERROR,SPONLIST,TEMLIST
-        S RIEN=$P(RTP,U,1)
-        ;
-        ;Get the list of definition findings and start the sponsor list.
-        D GETDFIND(RIEN,.FINDLIST)
-        ;
-        ;Add term findings to the list.
-        D GETTFIND(.FINDLIST)
-        ;
-        ;If a dialog exists for this reminder add it and its findings to the
-        ;list. Also collect any embedded TIU objects or templates
-        D DIALOG^PXRMEXDG(RIEN,.DLGLIST,.FINDLIST,.OBJLIST,.TEMLIST,.SPONLIST)
-        ;
-        ;If there were education topics make sure subtopics are included.
-        D SUB^PXRMEXED(.FINDLIST)
-        ;
-        ;The finding list is complete, search the definition, dialog and
-        ;all the findings for sponsors.
-        D BLDSPON(RIEN,.FINDLIST,.SPONLIST)
-        ;
-        ;Put sponsors first on the file list.
-        S NUMF=0
-        S IND0=0
-        F  S IND0=$O(SPONLIST(IND0)) Q:IND0=""  D
-        . S IEN=0
-        . F  S IEN=$O(SPONLIST(IND0,IEN)) Q:IEN=""  D
-        .. S NUMF=NUMF+1
-        .. S FILELIST(NUMF)="REMINDER SPONSOR"_U_811.6_U_IEN
-        ;
-        ;Look for any computed findings and put the associated routines
-        ;on the routine list.
-        S (IEN,NUMR)=0
-        F  S IEN=$O(FINDLIST("REMINDER COMPUTED FINDINGS","F",IEN)) Q:IEN=""  D
-        . S ROUTINE=$P(^PXRMD(811.4,IEN,0),U,2)
-        . S NUMR=NUMR+1
-        . S RTNLIST(NUMR)=ROUTINE
-        ;
-        ;Go through the finding list and create the file list in the same
-        ;order as the finding list.
-        S FILENAME=""
-        F  S FILENAME=$O(FINDLIST(FILENAME)) Q:FILENAME=""  D
-        . S FILENUM=FINDLIST(FILENAME)
-        . S IND0=""
-        . F  S IND0=$O(FINDLIST(FILENAME,IND0)) Q:IND0=""  D
-        .. S IEN=0
-        .. F  S IEN=$O(FINDLIST(FILENAME,IND0,IEN)) Q:IEN=""  D
-        ... S NUMF=NUMF+1
-        ... S FILELIST(NUMF)=FILENAME_U_FILENUM_U_IEN
-        ;
-        ;Add TIU templates to the file list.
-        S IND0=0
-        F  S IND0=$O(TEMLIST(IND0)) Q:IND0=""  D
-        . S IEN=$$EXISTS^PXRMEXIU(8927.1,TEMLIST(IND0))
-        . S NUMF=NUMF+1
-        . S FILELIST(NUMF)="TIU TEMPLATE FIELD"_U_8927.1_U_IEN
-        ;
-        ;Put the reminder at next to last.
-        S NUMF=NUMF+1
-        S FILELIST(NUMF)="REMINDER DEFINITION"_U_811.9_U_RIEN
-        ;
-        ;Put dialogs last on the file list.
-        S FILENUM=$G(DLGLIST("DIALOG"))
-        S IND0=""
-        F  S IND0=$O(DLGLIST("DIALOG",IND0)) Q:IND0=""  D
-        . S IEN=""
-        . F  S IEN=$O(DLGLIST("DIALOG",IND0,IEN)) Q:IEN=""  D
-        .. S NUMF=NUMF+1
-        .. S FILELIST(NUMF)="REMINDER DIALOG"_U_FILENUM_U_IEN
-        ;
-        S SERROR=0
-        ;Put any routines into the ^TMP array.
-        D GRTN^PXRMEXPU(.RTNLIST,NUMR,TMPIND,.SERROR)
-        ;Put the GETS^DIQ extracts of the findings, dialogs, and
-        ;reminder definition into the ^TMP array.
-        D GDIQF^PXRMEXPU(.FILELIST,NUMF,TMPIND,.SERROR)
-        ;
-        ;If there were any errors saving the data kill the ^TMP array.
-        I SERROR K ^TMP(TMPIND,$J)
-        Q
-        ;
-        ;===============================================================
-PUTSRC(RTP,TMPIND)      ;Save the source information
-        N LOC
-        S LOC=$$SITE^VASITE
-        S ^TMP(TMPIND,$J,"SRC","REMINDER")=$P(RTP,U,2)
-        S ^TMP(TMPIND,$J,"SRC","USER")=$$GET1^DIQ(200,DUZ,.01)
-        S ^TMP(TMPIND,$J,"SRC","SITE")=$P(LOC,U,2)
-        S ^TMP(TMPIND,$J,"SRC","DATE")=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        Q
-        ;
+PXRMEXPR ; SLC/PKR/PJH - Routines to create packed reminder definitions. ;02/25/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;===============================================================
+ADDFILE(FLIST,ROOT,FILENAME) ;Add a file to the list of finding files.
+ N DIC,DO,FILENUM
+ S DIC="^"_ROOT
+ K DO
+ D DO^DIC1
+ S FILENUM=+DO(2)
+ S FILENAME=$P(DO,U,1)
+ S FLIST(FILENAME)=FILENUM
+ Q
+ ;
+ ;===============================================================
+ADDFIND(FLIST,FILENAME,IEN) ;Add a finding to the list of findings.
+ S FLIST(FILENAME,"F",IEN)=""
+ ;Make sure categories are included for any health factors and they
+ ;come first in the list of health factors.
+ I FILENAME="HEALTH FACTORS" D
+ . N CAT
+ . S CAT=$P(^AUTTHF(IEN,0),U,3)
+ . S FLIST(FILENAME,"C",CAT)=""
+ Q
+ ;
+ ;===============================================================
+BLDSPON(RIEN,FINDLIST,SPONLIST) ;Build the sponsor list.
+ N DIEN,IEN,IND,IND0
+ ;Start with the definition.
+ D GETSPON(811.9,RIEN,.SPONLIST)
+ ;If there is a dialog add it.
+ S DIEN=+$P($G(^PXD(811.9,RIEN,51)),U,1)
+ I DIEN>0 D GETSPON(801.41,DIEN,.SPONLIST)
+ ;Go through the finding list to find additional sponsors.
+ S IND=""
+ F  S IND=$O(FINDLIST(IND)) Q:IND=""  D
+ . S FILENUM=FINDLIST(IND)
+ . I (FILENUM'<800)&(FILENUM'>811.9) D
+ .. S IND0=""
+ .. F  S IND0=$O(FINDLIST(IND,IND0)) Q:IND0=""  D
+ ... S IEN=""
+ ... F  S IEN=+$O(FINDLIST(IND,IND0,IEN)) Q:IEN=0  D
+ .... D GETSPON(FILENUM,IEN,.SPONLIST)
+ ;Add any associated sponsors to the begining of the list.
+ S IND=""
+ F  S IND=$O(SPONLIST("S",IND)) Q:IND=""  D
+ . S IND0=0
+ . F  S IND0=+$O(^PXRMD(811.6,IND,2,IND0)) Q:IND0=0  D
+ .. S IEN=+^PXRMD(811.6,IND,2,IND0,0)
+ .. S SPONLIST("A",IEN)=""
+ Q
+ ;
+ ;===============================================================
+BLDTEXT(TMPIND) ;Combine the source information and the user's input into the
+ ;"TEXT" array.
+ N IC,IND
+ S (IC,IND)=0
+ F  S IC=$O(^TMP(TMPIND,$J,"SRC",IC)) Q:+IC=0  D
+ . S IND=IND+1
+ . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"SRC",IC)
+ ;
+ S IC=0
+ F  S IC=$O(^TMP(TMPIND,$J,"TXT",1,IC)) Q:+IC=0  D
+ . S IND=IND+1
+ . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"TXT",1,IC,0)
+ Q
+ ;
+ ;===============================================================
+GETDFIND(RIEN,FLIST) ;Build the list of definition findings.
+ ;FLIST has the format FLIST(FILENAME)=file number, and for each
+ ;finding from the file FLIST(FILENAME,"F",IEN)="". For Health Factors
+ ;category entries are FLIST(FILENAME,"C",IEN)="".
+ N FILENAME,IEN,ROOT
+ S ROOT=""
+ F  S ROOT=$O(^PXD(811.9,RIEN,20,"E",ROOT)) Q:ROOT=""  D
+ . D ADDFILE(.FLIST,ROOT,.FILENAME)
+ . S IEN=0
+ . F  S IEN=$O(^PXD(811.9,RIEN,20,"E",ROOT,IEN)) Q:+IEN=0  D
+ .. D ADDFIND(.FLIST,FILENAME,IEN)
+ Q
+ ;
+ ;===============================================================
+GETSPON(FILENUM,IEN,SPONLIST) ;Add sponsors to the sponsor list.
+ N ENTRY,ROOT,SPONSOR
+ S ROOT=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+ S ENTRY=ROOT_IEN_",100)"
+ S ENTRY=$G(@ENTRY)
+ S SPONSOR=$P(ENTRY,U,2)
+ I SPONSOR'="" S SPONLIST("S",SPONSOR)=""
+ Q
+ ;
+ ;===============================================================
+GETTFIND(FLIST) ;If there are any terms in the list of findings go through
+ ;them and add the mapped findings to the list of findings.
+ I '$D(FLIST("REMINDER TERM")) Q
+ N FILENAME,ROOT,TIEN
+ S TIEN=0
+ F  S TIEN=$O(FLIST("REMINDER TERM","F",TIEN)) Q:+TIEN=0  D
+ . S ROOT=""
+ . F  S ROOT=$O(^PXRMD(811.5,TIEN,20,"E",ROOT)) Q:ROOT=""  D
+ .. D ADDFILE(.FLIST,ROOT,.FILENAME)
+ .. S IEN=0
+ .. F  S IEN=$O(^PXRMD(811.5,TIEN,20,"E",ROOT,IEN)) Q:+IEN=0  D
+ ... D ADDFIND(.FLIST,FILENAME,IEN)
+ Q
+ ;
+ ;===============================================================
+GETTEXT(RIEN,TMPIND,INDEX) ;Let the user input some text.
+ N DIC,DWLW,DWPK
+ ;If this is the description text, load the reminder description as
+ ;the default.
+ S RIEN=+RIEN
+ I RIEN>0 M ^TMP(TMPIND,$J,INDEX,1)=^PXD(811.9,RIEN,1)
+ S DIC="^TMP(TMPIND,$J,"""_INDEX_""",1,"
+ S DWLW=72
+ S DWPK=1
+ D EN^DIWE
+ Q
+ ;
+ ;===============================================================
+PACK(RTP,TMPIND) ;Create the packed reminder, store it in
+ ;^TMP(TMPIND,$J). TMPIND should be namespaced and set by the caller.
+ ;Save the source information
+ I +RTP'>0 Q
+ K ^TMP(TMPIND,$J)
+ D PUTSRC(RTP,TMPIND)
+ ;
+ ;Have the user input text that describes the reminder.
+ W !,"Enter a description of the reminder you are packing." H 3
+ D GETTEXT(RTP,TMPIND,"DESC")
+ ;
+ ;Have the user input keywords for indexing the reminder.
+ W !,"Enter keywords or phrases to help index the reminder you are packing."
+ W !,"Separate the keywords or phrases on each line with commas." H 3
+ D GETTEXT(0,TMPIND,"KEYWORD")
+ ;
+ ;Combine the source and input text into the "TEXT" array.
+ D BLDTEXT(TMPIND)
+ ;
+ W !,"Packing the reminder ... "
+ ;Build lists of the various reminder components.
+ N CF,IEN,IND0,FINDLIST,FILELIST,FILENAME,FILENUM,DLGLIST
+ N NUMF,NUMR,OBJLIST,RIEN,ROUTINE,RTNLIST
+ N SERROR,SPONLIST,TEMLIST
+ S RIEN=$P(RTP,U,1)
+ ;
+ ;Get the list of definition findings and start the sponsor list.
+ D GETDFIND(RIEN,.FINDLIST)
+ ;
+ ;Add term findings to the list.
+ D GETTFIND(.FINDLIST)
+ ;
+ ;If a dialog exists for this reminder add it and its findings to the
+ ;list. Also collect any embedded TIU objects or templates
+ D DIALOG^PXRMEXDG(RIEN,.DLGLIST,.FINDLIST,.OBJLIST,.TEMLIST)
+ ;
+ ;If there were education topics make sure subtopics are included.
+ D SUB^PXRMEXED(.FINDLIST)
+ ;
+ ;The finding list is complete, search the definition, dialog and
+ ;all the findings for sponsors.
+ D BLDSPON(RIEN,.FINDLIST,.SPONLIST)
+ ;
+ ;Put sponsors first on the file list.
+ S NUMF=0
+ S IND0=0
+ F  S IND0=$O(SPONLIST(IND0)) Q:IND0=""  D
+ . S IEN=0
+ . F  S IEN=$O(SPONLIST(IND0,IEN)) Q:IEN=""  D
+ .. S NUMF=NUMF+1
+ .. S FILELIST(NUMF)="REMINDER SPONSOR"_U_811.6_U_IEN
+ ;
+ ;Look for any computed findings and put the associated routines
+ ;on the routine list.
+ S (IEN,NUMR)=0
+ F  S IEN=$O(FINDLIST("REMINDER COMPUTED FINDINGS","F",IEN)) Q:IEN=""  D
+ . S ROUTINE=$P(^PXRMD(811.4,IEN,0),U,2)
+ . S NUMR=NUMR+1
+ . S RTNLIST(NUMR)=ROUTINE
+ ;
+ ;Go through the finding list and create the file list in the same
+ ;order as the finding list.
+ S FILENAME=""
+ F  S FILENAME=$O(FINDLIST(FILENAME)) Q:FILENAME=""  D
+ . S FILENUM=FINDLIST(FILENAME)
+ . S IND0=""
+ . F  S IND0=$O(FINDLIST(FILENAME,IND0)) Q:IND0=""  D
+ .. S IEN=0
+ .. F  S IEN=$O(FINDLIST(FILENAME,IND0,IEN)) Q:IEN=""  D
+ ... S NUMF=NUMF+1
+ ... S FILELIST(NUMF)=FILENAME_U_FILENUM_U_IEN
+ ;
+ ;Add TIU templates to the file list.
+ S IND0=0
+ F  S IND0=$O(TEMLIST(IND0)) Q:IND0=""  D
+ . S IEN=$$EXISTS^PXRMEXIU(8927.1,TEMLIST(IND0))
+ . S NUMF=NUMF+1
+ . S FILELIST(NUMF)="TIU TEMPLATE FIELD"_U_8927.1_U_IEN
+ ;
+ ;Put the reminder at next to last.
+ S NUMF=NUMF+1
+ S FILELIST(NUMF)="REMINDER DEFINITION"_U_811.9_U_RIEN
+ ;
+ ;Put dialogs last on the file list.
+ S FILENUM=$G(DLGLIST("DIALOG"))
+ S IND0=""
+ F  S IND0=$O(DLGLIST("DIALOG",IND0)) Q:IND0=""  D
+ . S IEN=""
+ . F  S IEN=$O(DLGLIST("DIALOG",IND0,IEN)) Q:IEN=""  D
+ .. S NUMF=NUMF+1
+ .. S FILELIST(NUMF)="REMINDER DIALOG"_U_FILENUM_U_IEN
+ ;
+ S SERROR=0
+ ;Put any routines into the ^TMP array.
+ D GRTN^PXRMEXPU(.RTNLIST,NUMR,TMPIND,.SERROR)
+ ;Put the GETS^DIQ extracts of the findings, dialogs, and
+ ;reminder definition into the ^TMP array.
+ D GDIQF^PXRMEXPU(.FILELIST,NUMF,TMPIND,.SERROR)
+ ;
+ ;If there were any errors saving the data kill the ^TMP array.
+ I SERROR K ^TMP(TMPIND,$J)
+ Q
+ ;
+ ;===============================================================
+PUTSRC(RTP,TMPIND) ;Save the source information
+ N LOC
+ S LOC=$$SITE^VASITE
+ S ^TMP(TMPIND,$J,"SRC","REMINDER")=$P(RTP,U,2)
+ ;S ^TMP(TMPIND,$J,"SRC","USER")=$P(^VA(200,DUZ,0),U,1)
+ S ^TMP(TMPIND,$J,"SRC","USER")=$$GET1^DIQ(200,DUZ,.01)
+ S ^TMP(TMPIND,$J,"SRC","SITE")=$P(LOC,U,2)
+ S ^TMP(TMPIND,$J,"SRC","DATE")=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m

@@ -1 @@
-PXRMEXPU        ; SLC/PKR - Utilities for packing and unpacking repository entries. ;09/10/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;==================================================
-BTTABLE(DIQOUT,IENROOT,TTABLE)  ;Build the DIQOUT to FDA iens translation table.
-        N FILENUM,IENS,IENT,IND,UP
-        S FILENUM=$O(DIQOUT(""))
-        I FILENUM="" Q
-        ;DBIA #2631
-        S UP=$G(^DD(FILENUM,0,"UP"))
-        ;Top level file in DIQOUT should not have an up node.
-        I UP="" D
-        . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS
-        . S TTABLE(FILENUM,IENS)="+"_IENS
-        E  D  Q
-        . W !,"BTTABLE^PXRMEXPU - DIQOUT problem, do not have correct top level"
-        ;
-        F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
-        . S UP=$G(^DD(FILENUM,0,"UP"))
-        . S IENS=""
-        . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
-        .. S IND=IND+1
-        .. S IENT=$P(IENS,",",2,99)
-        .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT)
-        .. S IENROOT(IND)=$P(IENS,",",1)
-        Q
-        ;
-        ;==================================================
-CLDIQOUT(DIQOUT)        ;Clean up DIQOUT remove null entries and change .01's
-        ;to the resolved form.
-        N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE
-        N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST
-        S FILENUM=""
-        F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
-        . K TYPE,VPTRLIST
-        . S IENS=""
-        . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
-        .. S FIELD=""
-        .. F  S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD=""  D
-        ...;If there is no data then don't keep this entry.
-        ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q
-        ...;Get the field type, if it is a variable-pointer then set up
-        ...;the resolved form.
-        ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE")
-        ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"")
-        ... ;Remove pointers to file 200.
-        ... I PTRTO="VA(200," S DIQOUT(FILENUM,IENS,FIELD)="" Q
-        ...;If the field's type is COMPUTED then don't transport it.
-        ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q
-        ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D
-        .... I '$D(VPTRLIST(FILENUM,FIELD)) D
-        ..... K VLIST
-        ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST)
-        ..... M VPTRLIST(FILENUM,FIELD)=VLIST
-        .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I")
-        .... S (PTRTO,ROOT)=$P(INTERNAL,";",2)
-        .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4)
-        .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD)
-        ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D
-        .... S (LINE,WPLCNT)=0
-        .... F  S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE=""  D
-        ..... S WPLCNT=WPLCNT+1
-        .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT
-        .... E  K DIQOUT(FILENUM,IENS,FIELD)
-        ...;For fields that point to files 80 and 80.1 we have to append a space
-        ...;so FileMan can resolve the pointers when installing a component.
-        ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" "
-        Q
-        ;
-        ;==================================================
-CONTOFDA(DIQOUT,IENROOT)        ;Convert the iens from the form
-        ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE.
-        ;DIQOUT contains the GETS^DIQ output. If any of the fields are
-        ;variable pointers change them to the resolved form.
-        N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE
-        ;Clean up DIQOUT remove null entries and change .01's to the resolved
-        ;form.
-        D CLDIQOUT(.DIQOUT)
-        ;Convert the iens to the adding FDA form .
-        D BTTABLE(.DIQOUT,.IENROOT,.TTABLE)
-        S FILENUM=""
-        F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
-        . S IENS=""
-        . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
-        .. S IENSA=TTABLE(FILENUM,IENS)
-        .. S FIELD=""
-        .. F  S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD=""  D
-        ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD)
-        .. K DIQOUT(FILENUM,IENS)
-        Q
-        ;
-        ;==================================================
-GDIQF(LIST,NUM,TMPIND,SERROR)   ;Save file entries into ^TMP(TMPIND,$J).
-        N CSUM,DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
-        S ^TMP(TMPIND,$J,"NUMF")=NUM
-        F IND=1:1:NUM D
-        . S TEMP=LIST(IND)
-        . S FILENAME=$P(TEMP,U,1)
-        . S FILENUM=$P(TEMP,U,2)
-        . S IEN=$P(TEMP,U,3)
-        . K DIQOUT,IENROOT
-        .;If the file entry is ok to install then get the entire entry,
-        .;otherwise just get the .01.
-        . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**"
-        . E  S FIELD=.01
-        . D GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG")
-        . I $D(MSG) D  Q
-        .. S SERROR=1,IND=NUM
-        .. N ETEXT
-        .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";"
-        .. W !,ETEXT
-        .. W !,"it returned the following error:"
-        .. D AWRITE^PXRMUTIL("MSG")
-        .. H 2
-        .. K MSG
-        .;Remove edit history from all reminder files.
-        . D RMEH(FILENUM,.DIQOUT)
-        .;Convert the iens to the FDA adding form.
-        . D CONTOFDA(.DIQOUT,.IENROOT)
-        . S CSUM=$$DIQOUTCS^PXRMEXCS(.DIQOUT)
-        . S ^TMP("PXRMEXCS",$J,IND,FILENAME)=CSUM
-        .;Load the converted DIQOUT into TMP.
-        . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT
-        . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT
-        Q
-        ;
-        ;==================================================
-GETREM(ACTION)  ;Get the reminder to save.
-        N DIC,DUOUT,X,Y
-        S DIC="^PXD(811.9,"
-        S DIC(0)="AEMQ"
-        S DIC("A")="Select Reminder Definition to "_ACTION_": "
-        D ^DIC
-        Q Y
-        ;
-        ;==================================================
-GRTN(LIST,NUM,TMPIND,SERROR)    ;Save routines into ^TMP(TMPIND,$J).
-        N DIF,IEN,IND,RA,TEMP,X,XCNP
-        S ^TMP(TMPIND,$J,"NUMR")=NUM
-        S X=""
-        F IND=1:1:NUM D
-        .;Make sure the routine exists.
-        . S X=LIST(IND)
-        . X ^%ZOSF("TEST")
-        . I $T D
-        .. K RA
-        .. S DIF="RA("
-        .. S XCNP=0
-        .. X ^%ZOSF("LOAD")
-        .. S ^TMP("PXRMEXCS",$J,"ROUTINE",X)=$$ROUTINE^PXRMEXCS(.RA)
-        .. M ^TMP(TMPIND,$J,"ROUTINE",X)=RA
-        . E  D
-        .. S SERROR=1
-        .. W !,"Warning could not find routine ",X
-        .. H 2
-        Q
-        ;
-        ;==================================================
-RMEH(FILENUM,DIQOUT,NOSTUB)     ;Clear the edit history from all reminder files.
-        ;Leave a stub so it can be filled in when the file is installed.
-        I (FILENUM<800)!(FILENUM>811.9) Q
-        N IENS,SFN,TARGET
-        ;Edit History is stored in node 110 for all files, get the
-        ;subfile number.
-        D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET")
-        S SFN=+$G(TARGET("SPECIFIER"))
-        I SFN=0 Q
-        ;Clean out the history.
-        S IENS=""
-        F  S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS=""  K DIQOUT(SFN,IENS)
-        ;Create a stub for the install.
-        I $G(NOSTUB) Q
-        S IENS="1,"_$O(DIQOUT(FILENUM,""))
-        S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
-        S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)"
-        S DIQOUT(SFN,IENS,2,1)="Exchange Stub"
-        Q
-        ;
-        ;==================================================
-UPDATE(SUCCESS,FDA,FDAIEN)      ;Call to add new entries to the repository.
-        N MSG
-        ;Try to eliminate gaps in the repository.
-        S $P(^PXD(811.8,0),U,3)=0
-        D UPDATE^DIE("E","FDA","FDAIEN","MSG")
-        I $D(MSG) D
-        . N DATE,RNAME
-        . S SUCCESS=0
-        . W !,"The update failed, UPDATE^DIE returned the following error message:"
-        . D AWRITE^PXRMUTIL("MSG")
-        . S RNAME=FDA(811.8,"+1,",.01)
-        . S DATE=FDA(811.8,"+1,",.03)
-        . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!"
-        . W !,"Examine the above error message for the reason.",!
-        . H 2
-        E  S SUCCESS=1
-        Q
-        ;
+PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;==================================================
+BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table.
+ N FILENUM,IENS,IENT,IND,UP
+ S FILENUM=$O(DIQOUT(""))
+ I FILENUM="" Q
+ ;DBIA #2631
+ S UP=$G(^DD(FILENUM,0,"UP"))
+ ;Top level file in DIQOUT should not have an up node.
+ I UP="" D
+ . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS
+ . S TTABLE(FILENUM,IENS)="+"_IENS
+ E  D  Q
+ . W !,"BTTABLE^PXRMEXPU - DIQOUT problem do not have correct top level"
+ ;
+ F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
+ . S UP=$G(^DD(FILENUM,0,"UP"))
+ . S IENS=""
+ . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
+ .. S IND=IND+1
+ .. S IENT=$P(IENS,",",2,99)
+ .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT)
+ .. S IENROOT(IND)=$P(IENS,",",1)
+ Q
+ ;
+ ;==================================================
+CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's
+ ;to the resolved form.
+ N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE
+ N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST
+ S FILENUM=""
+ F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
+ . K TYPE,VPTRLIST
+ . S IENS=""
+ . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
+ .. S FIELD=""
+ .. F  S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD=""  D
+ ...;If there is no data then don't keep this entry.
+ ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q
+ ...;Get the field type, if it is a variable-pointer then set up
+ ...;the resolved form.
+ ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE")
+ ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"")
+ ...;If the field's type is COMPUTED then don't transport it.
+ ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q
+ ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D
+ .... I '$D(VPTRLIST(FILENUM,FIELD)) D
+ ..... K VLIST
+ ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST)
+ ..... M VPTRLIST(FILENUM,FIELD)=VLIST
+ .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I")
+ .... S (PTRTO,ROOT)=$P(INTERNAL,";",2)
+ .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4)
+ .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD)
+ ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D
+ .... S (LINE,WPLCNT)=0
+ .... F  S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE=""  D
+ ..... S WPLCNT=WPLCNT+1
+ .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT
+ .... E  K DIQOUT(FILENUM,IENS,FIELD)
+ ...;For fields that point to files 80 and 80.1 we have to append a space
+ ...;so FileMan can resolve the pointers when installing a component.
+ ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" "
+ Q
+ ;
+ ;==================================================
+CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form
+ ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE.
+ ;DIQOUT contains the GETS^DIQ output. If any of the fields are
+ ;variable pointers change them to the resolved form.
+ N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE
+ ;Clean up DIQOUT remove null entries and change .01's to the resolved
+ ;form.
+ D CLDIQOUT(.DIQOUT)
+ ;Convert the iens to the adding FDA form .
+ D BTTABLE(.DIQOUT,.IENROOT,.TTABLE)
+ S FILENUM=""
+ F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
+ . S IENS=""
+ . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
+ .. S IENSA=TTABLE(FILENUM,IENS)
+ .. S FIELD=""
+ .. F  S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD=""  D
+ ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD)
+ .. K DIQOUT(FILENUM,IENS)
+ Q
+ ;
+ ;==================================================
+GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J).
+ N DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
+ S ^TMP(TMPIND,$J,"NUMF")=NUM
+ F IND=1:1:NUM D
+ . S TEMP=LIST(IND)
+ . S FILENAME=$P(TEMP,U,1)
+ . S FILENUM=$P(TEMP,U,2)
+ . S IEN=$P(TEMP,U,3)
+ . K DIQOUT,IENROOT
+ .;If the file entry is ok to install then get the entire entry,
+ .;otherwise just get the .01.
+ . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**"
+ . E  S FIELD=.01
+ . D GETS^DIQ(FILENUM,IEN,FIELD,"","DIQOUT","MSG")
+ . I $D(MSG) D  Q
+ .. S SERROR=1,IND=NUM
+ .. N ETEXT
+ .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";"
+ .. W !,ETEXT
+ .. W !,"it returned the following error:"
+ .. D AWRITE^PXRMUTIL("MSG")
+ .. H 2
+ .. K MSG
+ .;Remove edit history from all reminder files.
+ . D RMEH(FILENUM,.DIQOUT)
+ .;Convert the iens to the FDA adding form.
+ . D CONTOFDA(.DIQOUT,.IENROOT)
+ .;Load the converted DIQOUT into TMP.
+ . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT
+ . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT
+ Q
+ ;
+ ;==================================================
+GETREM(ACTION) ;Get the reminder to save.
+ N DIC,DUOUT,X,Y
+ S DIC="^PXD(811.9,"
+ S DIC(0)="AEMQ"
+ S DIC("A")="Select Reminder Definition to "_ACTION_": "
+ D ^DIC
+ Q Y
+ ;
+ ;==================================================
+GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J).
+ N DIF,IEN,IND,TEMP,X,XCNP
+ S ^TMP(TMPIND,$J,"NUMR")=NUM
+ S X=""
+ F IND=1:1:NUM D
+ .;Make sure the routine exists.
+ . S X=LIST(IND)
+ . X ^%ZOSF("TEST")
+ . I $T D
+ .. S DIF="^TMP(TMPIND,$J,""ROUTINE"","""_X_""","
+ .. S XCNP=0
+ .. X ^%ZOSF("LOAD")
+ . E  D
+ .. S SERROR=1
+ .. W !,"Warning could not find routine ",X
+ .. H 2
+ Q
+ ;
+ ;==================================================
+RMEH(FILENUM,DIQOUT) ;Clear the edit history from all reminder files.
+ ;Leave a stub so it can be filled in when the file is installed.
+ I (FILENUM<800)!(FILENUM>811.9) Q
+ N IEN,SFN,TARGET
+ ;Edit History is stored in node 110 for all files, get the
+ ;subfile number.
+ D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET")
+ S SFN=+$G(TARGET("SPECIFIER"))
+ I SFN=0 Q
+ ;Clean out the history.
+ S IENS=""
+ F  S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS=""  K DIQOUT(SFN,IENS)
+ ;Create a stub for the install.
+ S IENS="1,"_$O(DIQOUT(FILENUM,""))
+ S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
+ S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)"
+ S DIQOUT(SFN,IENS,2,1)="Exchange Stub"
+ Q
+ ;
+ ;==================================================
+UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository.
+ N MSG
+ ;Try to eliminate gaps in the repository.
+ S $P(^PXD(811.8,0),U,3)=0
+ D UPDATE^DIE("E","FDA","FDAIEN","MSG")
+ I $D(MSG) D
+ . N DATE,RNAME
+ . S SUCCESS=0
+ . W !,"The update failed, UPDATE^DIE returned the following error message:"
+ . D AWRITE^PXRMUTIL("MSG")
+ . S RNAME=FDA(811.8,"+1,",.01)
+ . S DATE=FDA(811.8,"+1,",.03)
+ . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!"
+ . W !,"Examine the above error message for the reason.",!
+ . H 2
+ E  S SUCCESS=1
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m

@@ -1 @@
-PXRMEXSI        ; SLC/PKR/PJH - Silent repository entry install. ;09/28/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;===================================================
-INITMPG ;Initialize ^TMP arrays.
-        K ^TMP("PXRMEXFND",$J)
-        K ^TMP("PXRMEXIA",$J)
-        K ^TMP("PXRMEXIAD",$J)
-        K ^TMP("PXRMEXLC",$J)
-        K ^TMP("PXRMEXLD",$J)
-        K ^TMP("PXRMEXTMP",$J)
-        Q
-        ;
-        ;===================================================
-INSCOM(PXRMRIEN,ACTION,IND,TEMP,REMNAME,HISTSUB)        ;Install component IND
-        ;of PXRMRIEN.
-        N ATTR,END,EXISTS,FILENUM,IND120,JND120,NAME
-        N PT01,RTN,SAME,START,TEXT
-        S FILENUM=$P(TEMP,U,1),EXISTS=$P(TEMP,U,4)
-        S IND120=$P(TEMP,U,2),JND120=$P(TEMP,U,3)
-        I (IND120="")!(JND120="") Q
-        S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)
-        ;If the component does not exist then the action has to be "I".
-        ;If the component exists and the action is "I" change it to "O".
-        ;If the component exists and the action is "M" leave it "M".
-        ;If the component exists and the action is "O" leave it "O".
-        S ACTION=$S('EXISTS:"I",ACTION="I":"O",1:ACTION)
-        S SAME=0
-        S START=$P(TEMP,U,2)
-        S END=$P(TEMP,U,3)
-        I FILENUM=0 D
-        . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
-        . I EXISTS D
-        .. D CHECKSUM^PXRMEXCS(.ATTR,START,END)
-        .. S CSUM=$$RTNCS^PXRMEXCS(ATTR("NAME"))
-        .. I ATTR("CHECKSUM")=CSUM S SAME=1,ACTION="S"
-        . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=""
-        E  D 
-        . S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
-        . S PT01=$P(TEMP,"~",2)
-        .;Save reminder name for dialog install.
-        . I FILENUM=811.9 S REMNAME=PT01
-        . D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
-        . I EXISTS D
-        .. D CHECKSUM^PXRMEXCS(.ATTR,START,END)
-        .. S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXISTS)
-        .. I ATTR("CHECKSUM")=CSUM S SAME=1,ACTION="S"
-        .;Save what was done for the installation summary.
-        . S ^TMP(HISTSUB,$J,IND,ATTR("FILE NAME"),PT01,ACTION)=""
-        ;If the packed component and the installed component are the same
-        ;there is nothing to do.
-        I SAME Q
-        ;Install this component.
-        I FILENUM=0 D RTNSAVE^PXRMEXIC(.RTN,ATTR("NAME"))
-        E  D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
-        Q
-        ;
-        ;===================================================
-INSDLG(PXRMRIEN,ACTION) ;Install dialog components directly
-        ;from the "SEL" array.
-        N IND,FILENUM,ITEMP,NAME,REMNAME,TEMP
-        ;Build the selection array in ^TMP("PXRMEXLD",$J,"SEL"). For dialogs
-        ;the selection array is: 
-        ;file no.^FDA start^FDA end^EXISTS^IND120^JND120^NAME
-        D BLDDISP^PXRMEXD1(0)
-        ;Work through the selection array installing the dialog parts
-        ;in reverse order.
-        S IND=""
-        F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(IND="")!(PXRMDONE)  D
-        . S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND)
-        . S FILENUM=$P(TEMP,U,1),NAME=$P(TEMP,U,7)
-        .;Dialog elements may be used more than once in a dialog so make sure
-        .;the element has not already been installed.
-        . S ITEMP=$P(TEMP,U,1)_U_$P(TEMP,U,5,6)_U_$$EXISTS^PXRMEXIU(FILENUM,NAME)
-        . D INSCOM(PXRMRIEN,ACTION,IND,ITEMP,.REMNAME,"PXRMEXIAD")
-        Q
-        ;
-        ;===================================================
-INSTALL(PXRMRIEN,ACTION,NOR)    ;Install all components in a repository entry.
-        ;If NOR is true do not install routines.
-        N DNAME,FILENUM,IND,PXRMDONE,PXRMNMCH,REMNAME,TEMP
-        S PXRMDONE=0
-        S NOR=$G(NOR)
-        ;Initialize ^TMP globals.
-        D INITMPG
-        ;Build the component list.
-        K ^PXD(811.8,PXRMRIEN,100,"B")
-        K ^PXD(811.8,PXRMRIEN,120)
-        D CLIST^PXRMEXU1(.PXRMRIEN)
-        I PXRMRIEN=-1 Q
-        ;Build the selectable list.
-        D CDISP^PXRMEXLC(PXRMRIEN)
-        ;Set the install date and time and type.
-        S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
-        S ^TMP("PXRMEXIA",$J,"TYPE")="SILENT"
-        ;Initialize the name change storage.
-        K PXRMNMCH
-        S IND=0
-        F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:(IND="")!(PXRMDONE)  D
-        . S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND)
-        . S FILENUM=$P(TEMP,U,1)
-        .;If NOR is true do not install routines.
-        . I FILENUM=0,NOR Q
-        . ;Install dialog components
-        . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN,ACTION) Q
-        . ;Install component
-        . E  D INSCOM(PXRMRIEN,ACTION,IND,TEMP,.REMNAME,"PXRMEXIA")
-        ;
-        ;Get the dialog name
-        S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
-        ;Link the dialog if it exists
-        I DNAME'="" D
-        . N DIEN,RIEN
-        .;Get the dialog ien
-        . S DIEN=$$EXISTS^PXRMEXIU(801.41,DNAME) Q:'DIEN
-        .;Get the reminder ien
-        . S RIEN=+$$EXISTS^PXRMEXIU(811.9,$G(REMNAME)) Q:'RIEN
-        . I RIEN>0 D
-        .. N DA,DIE,DIK,DR
-        ..;Set reminder to dialog pointer
-        .. S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=RIEN
-        .. D ^DIE
-        ;
-        ;Save the install history.
-        D SAVHIST^PXRMEXU1
-        ;If any components were skipped send the message.
-        I $D(^TMP("PXRMEXNI",$J)) D
-        . N NE,XMSUB
-        . S NE=$O(^TMP("PXRMEXNI",$J,""),-1)+1
-        . S ^TMP("PXRMEXNI",$J,NE,0)="Please review and make changes as necessary."
-        . K ^TMP("PXRMXMZ",$J)
-        . M ^TMP("PXRMXMZ",$J)=^TMP("PXRMEXNI",$J)
-        . S XMSUB="COMPONENTS SKIPPED DURING SILENT MODE INSTALL"
-        . D SEND^PXRMMSG(XMSUB)
-        ;Cleanup TMP globals.
-        D INITMPG
-        Q
-        ;
+PXRMEXSI ; SLC/PKR/PJH - Silent repository entry install. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;===================================================
+BUILD ;Build list manager workfile from ^TMP("PXRMEXTMP" (see ^PXRMEXLB)
+ N DDATA,DDLG,IND,JND,NLINE,NSEL
+ S NLINE=0,NSEL=0
+ S DDLG=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) Q:DDLG=""
+ ;
+ ;Save reminder dialog
+ S DDATA=^TMP("PXRMEXTMP",$J,"DLOC",DDLG)
+ S IND=$P(DDATA,U,3),JND=$P(DDATA,U,4)
+ D DSAVE(DDLG,IND,JND)
+ ;
+ ;Process sub-components
+ I $D(^TMP("PXRMEXTMP",$J,"DREPL",DDLG))>0 D DREPL(DDLG)
+ D DCMP(DDLG)
+ Q
+ ;
+ ;===================================================
+DCMP(DLG) ;Search for dialog components
+ N DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND
+ S DSEQ=0
+ F  S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)) Q:'DSEQ  D
+ . S DDATA=^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)
+ . S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ . S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Save line in workfile
+ . D DSAVE(DNAM,IND,JND)
+ .;
+ . I $D(^TMP("PXRMEXTMP",$J,"DREPL",DNAM))>0 D DREPL(DNAM)
+ .;Process any sub-components
+ . I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM)
+ Q
+ ;
+ ;===================================================
+DREPL(DLG,LEV) ;
+ N DDATA,DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND
+ S DDATA=^TMP("PXRMEXTMP",$J,"DREPL",DLG)
+ S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ ;Save line in workfile
+ D DSAVE(DNAM,IND,JND)
+ I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM)
+ Q
+ ;===================================================
+DSAVE(DNAM,IND,JND) ;Update workfile
+ ;Ignore national prompts
+ I $$PXRM^PXRMEXID(DNAM) Q
+ N DEXIST
+ S NSEL=NSEL+1
+ ;Check if dialog exists
+ S DEXIST=$$EXISTS^PXRMEXIU(801.41,DNAM)
+ ;Store the file number, start and stop line in the exchange file.
+ S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_IND_U_JND_U_DEXIST
+ Q
+ ;
+ ;===================================================
+INITMPG ;Initialize ^TMP arrays.
+ K ^TMP("PXRMEXIA",$J)
+ K ^TMP("PXRMEXLC",$J)
+ K ^TMP("PXRMEXLD",$J)
+ K ^TMP("PXRMEXTMP",$J)
+ Q
+ ;
+ ;===================================================
+INSCOM(PXRMRIEN,IND,TEMP,REMNAME) ;Install component IND of PXRMRIEN.
+ N ACTION,ATTR,END,EXISTS,FILENUM,IND120,JND120,NAME
+ N PT01,RTN,START
+ S FILENUM=$P(TEMP,U,1),EXISTS=$P(TEMP,U,4)
+ S IND120=$P(TEMP,U,2),JND120=$P(TEMP,U,3)
+ S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)
+ I (FILENUM=801.41)!(FILENUM=811.5) S ACTION=$S(EXISTS:"M",1:"I")
+ E  S ACTION=$S(EXISTS:"O",1:"I")
+ S START=$P(TEMP,U,2)
+ S END=$P(TEMP,U,3)
+ S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
+ I FILENUM=0 D
+ . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
+ .;Save what was done for the installation summary.
+ . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=""
+ E  D 
+ . S PT01=$P(TEMP,"~",2)
+ . S (ATTR("NAME"),ATTR("PT01"))=PT01
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM)
+ .;Save what was done for the installation summary.
+ . S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),PT01,ACTION)=""
+ ;Install this component.
+ I FILENUM=0 D RTNSAVE^PXRMEXIC(.RTN,ATTR("NAME"))
+ E  D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
+ ;Save reminder name
+ I FILENUM=811.9 S REMNAME=PT01
+ ;If this component was not installed add to the no install message.
+ Q
+ ;
+ ;===================================================
+INSDLG(PXRMRIEN) ;Install dialog components (in reverse order)
+ ;
+ K ^TMP("PXRMEXSI",$J)
+ N IND,TEMP,JND120,KIDSDONE
+ ;Build list of components
+ D BUILD
+ S IND="",KIDSDONE=0
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:'IND!(KIDSDONE=1)  D
+ . S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),JND120=$P(TEMP,U,3)
+ .;Skip install if dialog occurs more than once
+ . I $D(^TMP("PXRMEXSI",$J,JND120)) Q
+ . S ^TMP("PXRMEXSI",$J,JND120)=""
+ .;Silent Dialog Install
+ . D INSCOM(PXRMRIEN,IND,TEMP,.REMNAME)
+ K ^TMP("PXRMEXSI",$J)
+ Q
+ ;
+ ;===================================================
+INSTALL(PXRMRIEN,NOR) ;Install all components in a repository entry.
+ ;If NOR is true do not install routines.
+ N DNAME,FILENUM,IND,PXRMNMCH,REMNAME,TEMP
+ S NOR=$G(NOR)
+ ;Initialize ^TMP globals.
+ D INITMPG
+ ;Build the component list.
+ K ^PXD(811.8,PXRMRIEN,100,"B")
+ K ^PXD(811.8,PXRMRIEN,120)
+ D CLIST^PXRMEXU1(.PXRMRIEN)
+ I PXRMRIEN=-1 Q
+ ;Build the selectable list.
+ D CDISP^PXRMEXLC(PXRMRIEN)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;Initialize the name change storage.
+ K PXRMNMCH
+ S IND=0
+ F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:+IND=0  D
+ . S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND)
+ . S FILENUM=$P(TEMP,U,1)
+ .;If NOR is true do not install routines.
+ . I FILENUM=0,NOR Q
+ . ;Install dialog components
+ . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN) Q
+ . ;Install component
+ . E  D INSCOM(PXRMRIEN,IND,TEMP,.REMNAME)
+ ;
+ ;Get the dialog name
+ S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
+ ;Link the dialog if it exists
+ I DNAME'="" D
+ . N DIEN,RIEN
+ .;Get the dialog ien
+ . S DIEN=$$EXISTS^PXRMEXIU(801.41,DNAME) Q:'DIEN
+ .;Get the reminder ien
+ . S RIEN=+$$EXISTS^PXRMEXIU(811.9,$G(REMNAME)) Q:'RIEN
+ . I RIEN>0 D
+ .. N DA,DIE,DIK,DR
+ ..;Set reminder to dialog pointer
+ .. S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=RIEN
+ .. D ^DIE
+ ;
+ ;Save the install history.
+ D SAVHIST^PXRMEXU1
+ ;If any components were skipped send the message.
+ I $D(^TMP("PXRMEXNI",$J)) D
+ . N NE,XMSUB
+ . S NE=$O(^TMP("PXRMEXNI",$J,""),-1)+1
+ . S ^TMP("PXRMEXNI",$J,NE,0)="Please review and make changes as necessary."
+ . K ^TMP("PXRMXMZ",$J)
+ . M ^TMP("PXRMXMZ",$J)=^TMP("PXRMEXNI",$J)
+ . S XMSUB="COMPONENTS SKIPPED DURING SILENT MODE INSTALL"
+ . D SEND^PXRMMSG(XMSUB)
+ ;Cleanup TMP globals.
+ D INITMPG
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m

@@ -1 @@
-PXRMEXU1        ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;08/16/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;=====================================================
-CLIST(IEN)      ;Build the list of components for the repository
-        ;entry IEN. EXTYPE is the type of Exchange entry. The default is
-        ;reminder.
-        N COMIND,COMORDR,CSTART,CSUM,END,FILENAME,FILENUM
-        N IND,INDEXAT,JND,LINE,NCMPNT,NCTYPE,NITEMS,NLINES,NUMCMPNT
-        N PT01,START,TEMP,TAG,TYPE,UCOM,VERSN
-        S LINE=^PXD(811.8,IEN,100,1,0)
-        ;Make sure it is XML version 1.
-        I LINE'["<?xml version=""1.0""" D  Q
-        . W !,"Exchange file entry not in proper format!"
-        . S IEN=-1
-        . H 2
-        S LINE=^PXD(811.8,IEN,100,2,0)
-        I LINE'="<REMINDER_EXCHANGE_FILE_ENTRY>" D  Q
-        . W !,"Not an Exchange File entry!"
-        . S IEN=-1
-        . H 2
-        S LINE=^PXD(811.8,IEN,100,3,0)
-        S VERSN=$$GETTAGV^PXRMEXU3(LINE,"<PACKAGE_VERSION>")
-        S LINE=^PXD(811.8,IEN,100,4,0)
-        S INDEXAT=+$P(LINE,"<INDEX_AT>",2)
-        S LINE=^PXD(811.8,IEN,100,INDEXAT,0)
-        I LINE'="<INDEX>" D  Q
-        . W !,"Index missing, cannot continue!"
-        . S IEN=-1
-        . H 2
-        S JND=INDEXAT+1
-        S LINE=^PXD(811.8,IEN,100,JND,0)
-        S NCMPNT=+$$GETTAGV^PXRMEXU3(LINE,"<NUMBER_OF_COMPONENTS>")
-        K ^TMP($J,"CMPNT")
-        F IND=1:1:NCMPNT D
-        . K END,START
-        . F  S JND=JND+1,LINE=^PXD(811.8,IEN,100,JND,0) Q:LINE="</COMPONENT>"  D
-        .. S TAG=$$GETTAG^PXRMEXU3(LINE)
-        .. I TAG["START" S START(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG)
-        .. I TAG["END" S END(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG)
-        . I $D(START("<M_ROUTINE_START>")) D
-        .. S CSTART=START("<M_ROUTINE_START>")
-        .. S ^TMP($J,"CMPNT",IND,"TYPE")="ROUTINE"
-        .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0)
-        .. S ^TMP($J,"CMPNT",IND,"NAME")=$$GETTAGV^PXRMEXU3(LINE,"<ROUTINE_NAME>")
-        .. S ^TMP($J,"CMPNT",IND,"FILENUM")=0
-        ..;Save the actual start and end of the code.
-        .. S ^TMP($J,"CMPNT",IND,"START")=START("<ROUTINE_CODE_START>")
-        .. S ^TMP($J,"CMPNT",IND,"END")=END("<ROUTINE_CODE_END>")
-        . I $D(START("<FILE_START>")) D
-        .. S CSTART=START("<FILE_START>")
-        .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0)
-        .. S (^TMP($J,"CMPNT",IND,"TYPE"),^TMP($J,"CMPNT",IND,"FILENAME"))=$$GETTAGV^PXRMEXU3(LINE,"<FILE_NAME>",1)
-        .. S LINE=^PXD(811.8,IEN,100,CSTART+2,0)
-        .. S ^TMP($J,"CMPNT",IND,"FILENUM")=$$GETTAGV^PXRMEXU3(LINE,"<FILE_NUMBER>")
-        .. S LINE=^PXD(811.8,IEN,100,CSTART+3,0)
-        .. S (^TMP($J,"CMPNT",IND,"NAME"),^TMP($J,"CMPNT",IND,"POINT_01"))=$$GETTAGV^PXRMEXU3(LINE,"<POINT_01>",1)
-        ..;Save the actual start and end of the FileMan FDA.
-        .. S ^TMP($J,"CMPNT",IND,"FDA_START")=START("<FDA_START>")
-        .. S ^TMP($J,"CMPNT",IND,"FDA_END")=END("<FDA_END>")
-        .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_START")=$G(START("<IEN_ROOT_START>"))
-        .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_END")=$G(END("<IEN_ROOT_END>"))
-        ;Build some indexes to order the component list.
-        F IND=1:1:NCMPNT D
-        . S TYPE=^TMP($J,"CMPNT",IND,"TYPE")
-        . S COMIND(TYPE,IND)=""
-        . S UCOM(TYPE)=""
-        ;Build the component order for display and install.
-        D CORDER^PXRMEXCO(IEN,.UCOM,.NUMCMPNT,.COMORDR)
-        ;Set the 0 node.
-        S ^PXD(811.8,IEN,120,0)=U_"811.802A"_U_NCMPNT_U_NCMPNT
-        S NCTYPE=0
-        S NITEMS=0
-        F NCTYPE=1:1:NUMCMPNT D
-        . S TYPE=$O(COMORDR(NCTYPE,""))
-        . S NITEMS=0
-        . S IND=""
-        . F  S IND=$O(COMIND(TYPE,IND)) Q:IND=""  D
-        .. S NITEMS=NITEMS+1
-        .. I NITEMS=1 S FILENUM=^TMP($J,"CMPNT",IND,"FILENUM")
-        .. I TYPE="ROUTINE" S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"START")_U_^TMP($J,"CMPNT",IND,"END")
-        .. E  S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"FDA_START")_U_^TMP($J,"CMPNT",IND,"FDA_END")_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_START"))_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_END"))
-        .. S ^PXD(811.8,IEN,120,NCTYPE,1,NITEMS,0)=TEMP
-        . S ^PXD(811.8,IEN,120,NCTYPE,0)=TYPE_U_FILENUM_U_NITEMS
-        . S ^PXD(811.8,IEN,120,NCTYPE,1,0)=U_"811.8021A"_U_NITEMS_U_NITEMS
-        ;
-        ;Save the number of component types.
-        S ^PXD(811.8,IEN,119)=NCTYPE
-        K ^TMP($J,"CMPNT")
-        Q
-        ;
-        ;=====================================================
-DELETE(LIST)    ;Delete the repository entries in LIST.
-        N DA,DIK
-        S DIK="^PXD(811.8,"
-        S DA=""
-        F  S DA=$O(LIST(DA)) Q:+DA=0  D ^DIK
-        Q
-        ;
-        ;=====================================================
-DELHIST(RIEN,IHIEN)     ;Delete install history IHIEN in repository entry RIEN.
-        N DA,DIK
-        S DA=IHIEN,DA(1)=RIEN
-        S DIK="^PXD(811.8,"_DA(1)_",130,"
-        D ^DIK
-        Q
-        ;
-        ;=====================================================
-DESC(RIEN,DESL,DESC,KEYWORD)    ;Build the description.
-        N JND,LC,NKEYW
-        S LC=1
-        S ^PXD(811.8,RIEN,110,LC,0)="Reminder:    "_DESL("RNAME")
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)="Source:      "_DESL("SOURCE")
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)="Date Packed: "_DESL("DATEP")
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)="Package Version: "_DESL("VRSN")
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)=""
-        ;Add the user's description.
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)="Description:"
-        F JND=1:1:+$P($G(@DESC@(1,0)),U,4) D
-        . S LC=LC+1
-        . S ^PXD(811.8,RIEN,110,LC,0)=@DESC@(1,JND,0)
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)=""
-        ;Add the keywords.
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)="Keywords:"
-        S NKEYW=+$P($G(@KEYWORD@(1,0)),U,4)
-        I NKEYW=0 D
-        . S LC=LC+1
-        . S ^PXD(811.8,RIEN,110,LC,0)="No keywords given"
-        F JND=1:1:NKEYW D
-        . S LC=LC+1
-        . S ^PXD(811.8,RIEN,110,LC,0)=@KEYWORD@(1,JND,0)
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)=""
-        S LC=LC+1
-        S ^PXD(811.8,RIEN,110,LC,0)="Components:"
-        S ^PXD(811.8,RIEN,110,0)=U_811.804_U_LC_U_LC
-        Q
-        ;
-        ;=====================================================
-RIEN(LIEN)      ;Given the list ien return the repository ien.
-        N RIEN
-        S RIEN=$G(^TMP("PXRMEXLR",$J,"SEL",LIEN))
-        Q RIEN
-        ;
-        ;=====================================================
-SAVHIST ;Save the installation history in the repository.
-        N ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,NEWNAME
-        N SUB,TEMP,TOTAL,TYPE,USER
-        ;Find the first open spot in the Installation History node.
-        S (IND,JND)=0
-        F  S IND=+$O(^PXD(811.8,PXRMRIEN,130,IND)) S JND=JND+1 Q:(IND=0)!(IND>JND)
-        S IND=JND
-        S JND=0
-        F SUB="PXRMEXIA","PXRMEXIAD" D
-        . S INDEX=0
-        . F  S INDEX=$O(^TMP(SUB,$J,INDEX)) Q:+INDEX=0  D
-        .. S JND=JND+1
-        .. S CMPNT=$O(^TMP(SUB,$J,INDEX,""))
-        .. S ITEM=$O(^TMP(SUB,$J,INDEX,CMPNT,""))
-        .. S ACTION=$O(^TMP(SUB,$J,INDEX,CMPNT,ITEM,""))
-        .. S NEWNAME=$G(^TMP(SUB,$J,INDEX,CMPNT,ITEM,ACTION))
-        .. S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
-        ..;Set the 0 node.
-        .. S ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
-        ..;Check for finding item changes and save them.
-        .. S FTYPE=""
-        .. I CMPNT["DEFINITION" S FTYPE="DEFF"
-        .. I CMPNT["DIALOG" S FTYPE="DIAF"
-        .. I CMPNT["TERM" S FTYPE="TRMF"
-        .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
-        ... N FI,FINDING,KND,OFINDING
-        ... S KND=2
-        ... S FI=""
-        ... F  S FI=$O(^TMP(SUB,$J,FTYPE,FI)) Q:FI=""  D
-        .... S OFINDING=$O(^TMP(SUB,$J,FTYPE,FI,""))
-        .... S FINDING=^TMP(SUB,$J,FTYPE,FI,OFINDING)
-        .... I OFINDING=FINDING Q
-        .... S KND=KND+1
-        .... S TEMP=$E(OFINDING,1,33)
-        .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_FINDING
-        ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
-        ... I KND>2 D
-        .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   Finding Changes"
-        .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
-        ..;
-        ..;Check for TIU template replacements and save them.
-        .. I CMPNT["DIALOG" S FTYPE="DIATIU"
-        .. E  S FTYPE=""
-        .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
-        ... N KND,OTIUT,TIUT,TYPE
-        ... S TYPE=""
-        ... S KND=2
-        ... F  S TYPE=$O(^TMP(SUB,$J,FTYPE,TYPE)) Q:TYPE=""  D
-        .... S OTIUT=""
-        .... F  S OTIUT=$O(^TMP(SUB,$J,FTYPE,TYPE,OTIUT)) Q:OTIUT=""  D
-        ..... S TIUT=$G(^TMP(SUB,$J,FTYPE,TYPE,OTIUT))
-        ..... I OTIUT=TIUT Q
-        ..... I '$D(^TMP(SUB,$J,FTYPE,TYPE,OTIUT,ITEM)) Q
-        ..... S KND=KND+1
-        ..... S TEMP=$E(OTIUT,1,33)
-        ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_TIUT
-        .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
-        .... I KND>2 D
-        ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   "_TYPE
-        ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
-        ;If JND is still 0 then there was nothing to save.
-        I JND>0 D
-        .;Save the header information.
-        . S DATE=^TMP("PXRMEXIA",$J,"DT")
-        . S TYPE=^TMP("PXRMEXIA",$J,"TYPE")
-        . S USER=$$GET1^DIQ(200,DUZ,.01,"")
-        . S ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER_U_TYPE
-        . S ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
-        .;Set the 0 node.
-        . S (KND,TOTAL)=0
-        . F  S KND=+$O(^PXD(811.8,PXRMRIEN,130,KND)) Q:KND=0  S TOTAL=TOTAL+1
-        . S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_IND_U_TOTAL
-        K ^TMP("PXRMEXIA",$J)
-        K ^TMP("PXRMEXIAD",$J)
-        Q
-        ;
+PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1. ;09/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;=====================================================
+CLIST(IEN) ;Build the list of components for the repository
+ ;entry IEN. EXTYPE is the type of Exchange entry. The default is
+ ;reminder.
+ N COMIND,COMORDR,CSTART,CSUM,END,FILENAME,FILENUM
+ N IND,INDEXAT,JND,LINE,NCMPNT,NCTYPE,NITEMS,NLINES,NUMCMPNT
+ N PT01,START,TEMP,TAG,TYPE,UCOM,VERSN
+ S LINE=^PXD(811.8,IEN,100,1,0)
+ ;Make sure it is XML version 1.
+ I LINE'["<?xml version=""1.0""" D  Q
+ . W !,"Exchange file entry not in proper format!"
+ . S IEN=-1
+ . H 2
+ S LINE=^PXD(811.8,IEN,100,2,0)
+ I LINE'="<REMINDER_EXCHANGE_FILE_ENTRY>" D  Q
+ . W !,"Not an Exchange File entry!"
+ . S IEN=-1
+ . H 2
+ S LINE=^PXD(811.8,IEN,100,3,0)
+ S VERSN=$$GETTAGV^PXRMEXU3(LINE,"<PACKAGE_VERSION>")
+ S LINE=^PXD(811.8,IEN,100,4,0)
+ S INDEXAT=+$P(LINE,"<INDEX_AT>",2)
+ S LINE=^PXD(811.8,IEN,100,INDEXAT,0)
+ I LINE'="<INDEX>" D  Q
+ . W !,"Index missing, cannot continue!"
+ . S IEN=-1
+ . H 2
+ S JND=INDEXAT+1
+ S LINE=^PXD(811.8,IEN,100,JND,0)
+ S NCMPNT=+$$GETTAGV^PXRMEXU3(LINE,"<NUMBER_OF_COMPONENTS>")
+ K ^TMP($J,"CMPNT")
+ F IND=1:1:NCMPNT D
+ . K END,START
+ . F  S JND=JND+1,LINE=^PXD(811.8,IEN,100,JND,0) Q:LINE="</COMPONENT>"  D
+ .. S TAG=$$GETTAG^PXRMEXU3(LINE)
+ .. I TAG["START" S START(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG)
+ .. I TAG["END" S END(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG)
+ . I $D(START("<M_ROUTINE_START>")) D
+ .. S CSTART=START("<M_ROUTINE_START>")
+ .. S ^TMP($J,"CMPNT",IND,"TYPE")="ROUTINE"
+ .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0)
+ .. S ^TMP($J,"CMPNT",IND,"NAME")=$$GETTAGV^PXRMEXU3(LINE,"<ROUTINE_NAME>")
+ .. S ^TMP($J,"CMPNT",IND,"FILENUM")=0
+ ..;Save the actual start and end of the code.
+ .. S ^TMP($J,"CMPNT",IND,"START")=START("<ROUTINE_CODE_START>")
+ .. S ^TMP($J,"CMPNT",IND,"END")=END("<ROUTINE_CODE_END>")
+ . I $D(START("<FILE_START>")) D
+ .. S CSTART=START("<FILE_START>")
+ .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0)
+ .. S (^TMP($J,"CMPNT",IND,"TYPE"),^TMP($J,"CMPNT",IND,"FILENAME"))=$$GETTAGV^PXRMEXU3(LINE,"<FILE_NAME>",1)
+ .. S LINE=^PXD(811.8,IEN,100,CSTART+2,0)
+ .. S ^TMP($J,"CMPNT",IND,"FILENUM")=$$GETTAGV^PXRMEXU3(LINE,"<FILE_NUMBER>")
+ .. S LINE=^PXD(811.8,IEN,100,CSTART+3,0)
+ .. S (^TMP($J,"CMPNT",IND,"NAME"),^TMP($J,"CMPNT",IND,"POINT_01"))=$$GETTAGV^PXRMEXU3(LINE,"<POINT_01>",1)
+ ..;Save the actual start and end of the FileMan FDA.
+ .. S ^TMP($J,"CMPNT",IND,"FDA_START")=START("<FDA_START>")
+ .. S ^TMP($J,"CMPNT",IND,"FDA_END")=END("<FDA_END>")
+ .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_START")=$G(START("<IEN_ROOT_START>"))
+ .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_END")=$G(END("<IEN_ROOT_END>"))
+ ;Build some indexes to order the component list.
+ F IND=1:1:NCMPNT D
+ . S TYPE=^TMP($J,"CMPNT",IND,"TYPE")
+ . S COMIND(TYPE,IND)=""
+ . S UCOM(TYPE)=""
+ ;Build the component order for display and install.
+ D CORDER^PXRMEXCO(IEN,.UCOM,.NUMCMPNT,.COMORDR)
+ ;Set the 0 node.
+ S ^PXD(811.8,IEN,120,0)=U_"811.802A"_U_NCMPNT_U_NCMPNT
+ S NCTYPE=0
+ S NITEMS=0
+ F NCTYPE=1:1:NUMCMPNT D
+ . S TYPE=$O(COMORDR(NCTYPE,""))
+ . S NITEMS=0
+ . S IND=""
+ . F  S IND=$O(COMIND(TYPE,IND)) Q:IND=""  D
+ .. S NITEMS=NITEMS+1
+ .. I NITEMS=1 S FILENUM=^TMP($J,"CMPNT",IND,"FILENUM")
+ .. I TYPE="ROUTINE" S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"START")_U_^TMP($J,"CMPNT",IND,"END")
+ .. E  S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"FDA_START")_U_^TMP($J,"CMPNT",IND,"FDA_END")_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_START"))_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_END"))
+ .. S ^PXD(811.8,IEN,120,NCTYPE,1,NITEMS,0)=TEMP
+ . S ^PXD(811.8,IEN,120,NCTYPE,0)=TYPE_U_FILENUM_U_NITEMS
+ . S ^PXD(811.8,IEN,120,NCTYPE,1,0)=U_"811.8021A"_U_NITEMS_U_NITEMS
+ ;
+ ;Save the number of component types.
+ S ^PXD(811.8,IEN,119)=NCTYPE
+ K ^TMP($J,"CMPNT")
+ Q
+ ;
+ ;=====================================================
+DELETE(LIST) ;Delete the repository entries in LIST.
+ N DA,DIK
+ S DIK="^PXD(811.8,"
+ S DA=""
+ F  S DA=$O(LIST(DA)) Q:+DA=0  D ^DIK
+ Q
+ ;
+ ;=====================================================
+DELHIST(RIEN,IHIND) ;Delete install history IHIND in repository entry RIEN.
+ N DATE
+ S DATE=$P(^PXD(811.8,RIEN,130,IHIND,0),U)
+ K ^PXD(811.8,RIEN,130,IHIND)
+ K ^PXD(811.8,RIEN,130,"B",DATE)
+ Q
+ ;
+ ;=====================================================
+DESC(RIEN,DESL,DESC,KEYWORD) ;Build the description.
+ N JND,LC,NKEYW
+ S LC=1
+ S ^PXD(811.8,RIEN,110,LC,0)="Reminder:    "_DESL("RNAME")
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)="Source:      "_DESL("SOURCE")
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)="Date Packed: "_DESL("DATEP")
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)="Package Version: "_DESL("VRSN")
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)=""
+ ;Add the user's description.
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)="Description:"
+ F JND=1:1:+$P($G(@DESC@(1,0)),U,4) D
+ . S LC=LC+1
+ . S ^PXD(811.8,RIEN,110,LC,0)=@DESC@(1,JND,0)
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)=""
+ ;Add the keywords.
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)="Keywords:"
+ S NKEYW=+$P($G(@KEYWORD@(1,0)),U,4)
+ I NKEYW=0 D
+ . S LC=LC+1
+ . S ^PXD(811.8,RIEN,110,LC,0)="No keywords given"
+ F JND=1:1:NKEYW D
+ . S LC=LC+1
+ . S ^PXD(811.8,RIEN,110,LC,0)=@KEYWORD@(1,JND,0)
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)=""
+ S LC=LC+1
+ S ^PXD(811.8,RIEN,110,LC,0)="Components:"
+ S ^PXD(811.8,RIEN,110,0)=U_811.804_U_LC_U_LC
+ Q
+ ;
+ ;=====================================================
+RIEN(LIEN) ;Given the list ien return the repository ien.
+ N RIEN
+ S RIEN=$G(^TMP("PXRMEXLR",$J,"IDX",LIEN,LIEN))
+ Q RIEN
+ ;
+ ;=====================================================
+SAVHIST ;Save the installation history in the repository.
+ N ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,NEWNAME,TEMP,USER
+ ;Find the first open spot in the Installation History node.
+ S (IND,JND)=0
+ F  S IND=+$O(^PXD(811.8,PXRMRIEN,130,IND)) S JND=JND+1 Q:(IND=0)!(JND>IND)
+ ;Set the 0 node.
+ S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_JND_U_JND
+ S IND=JND
+ S DATE=^TMP("PXRMEXIA",$J,"DT")
+ S USER=$$GET1^DIQ(200,DUZ,.01,"")
+ S ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER
+ S ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
+ S (INDEX,JND)=0
+ F  S INDEX=$O(^TMP("PXRMEXIA",$J,INDEX)) Q:+INDEX=0  D
+ . S JND=JND+1
+ . S CMPNT=$O(^TMP("PXRMEXIA",$J,INDEX,""))
+ . S ITEM=$O(^TMP("PXRMEXIA",$J,INDEX,CMPNT,""))
+ . S ACTION=$O(^TMP("PXRMEXIA",$J,INDEX,CMPNT,ITEM,""))
+ . S NEWNAME=$G(^TMP("PXRMEXIA",$J,INDEX,CMPNT,ITEM,ACTION))
+ . S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
+ .;Set the 0 node.
+ . S ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
+ .;Check for finding item changes and save them.
+ . S FTYPE=""
+ . I CMPNT["DEFINITION" S FTYPE="DEFF"
+ . I CMPNT["DIALOG" S FTYPE="DIAF"
+ . I CMPNT["TERM" S FTYPE="TRMF"
+ . I (FTYPE'=""),($D(^TMP("PXRMEXIA",$J,FTYPE))) D
+ .. N FI,FINDING,KND,OFINDING
+ .. S KND=2
+ .. S FI=""
+ .. F  S FI=$O(^TMP("PXRMEXIA",$J,FTYPE,FI)) Q:FI=""  D
+ ... S OFINDING=$O(^TMP("PXRMEXIA",$J,FTYPE,FI,""))
+ ... S FINDING=^TMP("PXRMEXIA",$J,FTYPE,FI,OFINDING)
+ ... I OFINDING=FINDING Q
+ ... S KND=KND+1
+ ... S TEMP=$E(OFINDING,1,33)
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_FINDING
+ .. S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
+ .. I KND>2 D
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   Finding Changes"
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
+ .;
+ .;Check for TIU template replacements and save them.
+ . I CMPNT["DIALOG" S FTYPE="DIATIU"
+ . E  S FTYPE=""
+ . I (FTYPE'=""),($D(^TMP("PXRMEXIA",$J,FTYPE))) D
+ .. N KND,OTIUT,TIUT,TYPE
+ .. S TYPE=""
+ .. S KND=2
+ .. F  S TYPE=$O(^TMP("PXRMEXIA",$J,FTYPE,TYPE)) Q:TYPE=""  D
+ ... S OTIUT=""
+ ... F  S OTIUT=$O(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT)) Q:OTIUT=""  D
+ .... S TIUT=$G(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT))
+ .... I OTIUT=TIUT Q
+ .... I '$D(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT,ITEM)) Q
+ .... S KND=KND+1
+ .... S TEMP=$E(OTIUT,1,33)
+ .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_TIUT
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
+ ... I KND>2 D
+ .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   "_TYPE
+ .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
+ K ^TMP("PXRMEXIA",$J)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m

@@ -1 @@
-PXRMEXU2        ; SLC/PKR/PJH - Reminder exchange repository utilities, #2. ;11/21/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;=====================================================
-FDA(IND,LC,TMPIND,FILENAME)     ;Build the XML FDA output.
-        N FIELD,FILENUM,INDEX,INDEX0,JND,SIENS,WPC
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILEMAN_FDA>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
-        ;Get the file number.
-        S FILENUM=""
-        F  S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM)) Q:FILENUM=""  D
-        .;Get the source ien string.
-        . S SIENS=""
-        . F  S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS)) Q:SIENS=""  D
-        .. S INDEX0=FILENUM_";"_SIENS
-        ..;Get the field number and store the data.
-        .. S FIELD=""
-        .. F  S FIELD=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD)) Q:FIELD=""  D
-        ... S INDEX=INDEX0_";"_FIELD
-        ...;If there is another index past the field then this is a
-        ...;word-processing field.
-        ... I $D(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD))=11 D
-        .... S WPC=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD,""),-1)
-        .... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_"~WP-start~"_WPC
-        .... F JND=1:1:WPC D
-        ..... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD,JND)
-        ... E  S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_"~"_^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD)
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</FILEMAN_FDA>"
-        Q
-        ;
-        ;=====================================================
-IENROOT(IND,LC,TMPIND,FILENAME) ;Build the XML IEN_ROOT output.
-        N INDEX,VALUE
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<IEN_ROOT>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
-        S INDEX=0
-        F  S INDEX=$O(^TMP(TMPIND,$J,IND,FILENAME,INDEX)) Q:INDEX=""  D
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_U_^TMP(TMPIND,$J,IND,FILENAME,INDEX)
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</IEN_ROOT>"
-        Q
-        ;
-        ;=====================================================
-STOREPR(SUCCESS,RTM,TMPIND,EXTYPE)      ;^TMP(TMPIND,$J contains data to be
-        ;stored in the repository. Routines will be found in
-        ;^TMP(TMPIND,$J,"ROUTINE",ROUTINE NAME,n) where n is the line number.
-        ;File entries will be found in ^TMP(TMPIND,$J,N,FILENAME,indexes).
-        ;This is output from the GETS^DIQ call. There are NUMF file entries.
-        ;Format and store it as XML in the repository.
-        N DATE,DTEST,FDA,FILENAME,FILENUM
-        N IENROOT,IND,JND,LC,LINE,NCMPNT,NEWFILE,NUMF,PT01,RNAME
-        N SIENS,SOURCE,TEMP,VERSN
-        ;If anything went wrong in the packing process then ^TMP(TMPIND,$J
-        ;will not exist.
-        I '$D(^TMP(TMPIND,$J)) S SUCCESS=0 Q
-        ;
-        K ^TMP($J,"CIND")
-        K ^TMP("PXRMEXRS",$J)
-        S ^TMP("PXRMEXRS",$J,1,0)="<?xml version=""1.0"" standalone=""yes""?>"
-        S ^TMP("PXRMEXRS",$J,2,0)="<REMINDER_EXCHANGE_FILE_ENTRY>"
-        S VERSN=$P(^PXRM(800,1,"VERSION"),U,1)
-        S ^TMP("PXRMEXRS",$J,3,0)="<PACKAGE_VERSION>"_VERSN_"</PACKAGE_VERSION>"
-        ;The pointer to the index will be on line 4 so leave room.
-        S LC=4
-        ;Save the source information.
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<SOURCE>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<NAME>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","REMINDER"))_"</NAME>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<USER>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","USER"))_"</USER>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<SITE>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","SITE"))_"</SITE>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<DATE_PACKED>"_^TMP(TMPIND,$J,"SRC","DATE")_"</DATE_PACKED>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</SOURCE>"
-        ;
-        ;Save the Exchange Type.
-        I EXTYPE="" S EXTYPE="REMINDER"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<EXCHANGE_TYPE>"_$$TOXML^PXRMEXU3(EXTYPE)_"</EXCHANGE_TYPE>"
-        ;
-        ;Save the description.
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<DESCRIPTION><![CDATA["
-        S IND=0
-        F  S IND=$O(^TMP(TMPIND,$J,"DESC",1,IND)) Q:+IND=0  D
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,"DESC",1,IND,0)
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]></DESCRIPTION>"
-        ;
-        ;Save the keywords or phrases.
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORDS>"
-        S IND=0
-        F  S IND=$O(^TMP(TMPIND,$J,"KEYWORD",1,IND)) Q:+IND=0  D
-        . S TEMP=^TMP(TMPIND,$J,"KEYWORD",1,IND,0)
-        . I TEMP["," D
-        .. F JND=1:1:$L(TEMP,",") D
-        ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3($P(TEMP,",",JND))_"</KEYWORD>"
-        . E  S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3(TEMP)_"</KEYWORD>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</KEYWORDS>"
-        ;
-        S NCMPNT=0
-        ;Do routines first.
-        S RNAME=""
-        F  S RNAME=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME)) Q:RNAME=""  D
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<M_ROUTINE>"
-        . S NCMPNT=NCMPNT+1
-        . S ^TMP($J,"CIND",NCMPNT,"M_ROUTINE_START")=LC
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<ROUTINE_NAME>"_RNAME_"</ROUTINE_NAME>"
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,"ROUTINE",RNAME)_"</CHECKSUM>"
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CODE>"
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
-        . S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_START")=LC+1
-        . S LINE=0
-        . F  S LINE=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME,LINE)) Q:LINE=""  D
-        .. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,"ROUTINE",RNAME,LINE,0)
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</CODE>"
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</M_ROUTINE>"
-        . S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_END")=LC-3
-        ;
-        ;Do file entries.
-        ;For word processing fields the first line is
-        ;file number;source ien string;field~WP-start~line count
-        ;The next line count lines are the WP data.
-        S NUMF=+$G(^TMP(TMPIND,$J,"NUMF"))
-        S FILENAME=""
-        F IND=1:1:NUMF D
-        . F  S FILENAME=$O(^TMP(TMPIND,$J,IND,FILENAME)) Q:FILENAME=""  D
-        .. I FILENAME["IENROOT" D
-        ... S NEWFILE=0
-        ... S IENROOT=1
-        .. E  D
-        ... S NEWFILE=1
-        ... S IENROOT=0
-        .. I NEWFILE D
-        ... S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,""))
-        ... S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,""))
-        ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILEMAN_FILE>"
-        ... S NCMPNT=NCMPNT+1
-        ... S ^TMP($J,"CIND",NCMPNT,"FILE_START")=LC
-        ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILE_NAME>"_$$TOXML^PXRMEXU3(FILENAME)_"</FILE_NAME>"
-        ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILE_NUMBER>"_FILENUM_"</FILE_NUMBER>"
-        ... S LC=LC+1,PT01=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,.01)
-        ... S ^TMP("PXRMEXRS",$J,LC,0)="<POINT_01>"_$$TOXML^PXRMEXU3(PT01)_"</POINT_01>"
-        ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<INTERNAL_ENTRY_NUMBER>"_+SIENS_"</INTERNAL_ENTRY_NUMBER>"
-        ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,IND,FILENAME)_"</CHECKSUM>"
-        ... S ^TMP($J,"CIND",NCMPNT,"FDA_START")=LC+3
-        ... D FDA(IND,.LC,TMPIND,FILENAME)
-        ... S ^TMP($J,"CIND",NCMPNT,"FDA_END")=LC-2
-        ..;The ien root information always comes after the FDA.
-        .. I IENROOT D
-        ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_START")=LC+3
-        ... D IENROOT(IND,.LC,TMPIND,FILENAME)
-        ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_END")=LC-2
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</FILEMAN_FILE>"
-        ;Save the index.
-        S LC=LC+1,^TMP("PXRMEXRS",$J,4,0)="<INDEX_AT>"_LC_"</INDEX_AT>"
-        S ^TMP("PXRMEXRS",$J,LC,0)="<INDEX>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<NUMBER_OF_COMPONENTS>"_NCMPNT_"</NUMBER_OF_COMPONENTS>"
-        F IND=1:1:NCMPNT D
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<COMPONENT>"
-        . S JND=""
-        . F  S JND=$O(^TMP($J,"CIND",IND,JND)) Q:JND=""  D
-        .. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<"_JND_">"_^TMP($J,"CIND",IND,JND)_"</"_JND_">"
-        . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</COMPONENT>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</INDEX>"
-        S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</REMINDER_EXCHANGE_FILE_ENTRY>"
-        ;Establish the entry in the repository.
-        S RNAME=$P(RTM,U,2)
-        S SOURCE=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
-        S DATE=^TMP(TMPIND,$J,"SRC","DATE")
-        S FDA(811.8,"+1,",.01)=RNAME
-        S FDA(811.8,"+1,",.02)=SOURCE
-        S FDA(811.8,"+1,",.03)=DATE
-        S FDA(811.8,"+1,",115)=EXTYPE
-        D UPDATE^PXRMEXPU(.SUCCESS,.FDA,.IENROOT)
-        I SUCCESS D
-        . M ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXRS",$J)
-        .;Set the 0 node.
-        . S ^PXD(811.8,IENROOT(1),100,0)=U_811.801_U_LC_U_LC
-        .;Save the Exchange Type.
-        . S ^PXD(811.8,IENROOT(1),115)=$G(EXTYPE)
-        .;Create the description for this repository entry.
-        . N DATEP,DESC,DESL,KEYWORD,RNAME,SOURCE
-        . S DESL("RNAME")=^TMP(TMPIND,$J,"SRC","REMINDER")
-        . S DESL("SOURCE")=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
-        . S DESL("DATEP")=^TMP(TMPIND,$J,"SRC","DATE")
-        . S DESL("VRSN")=VERSN
-        . S DESC="^TMP(TMPIND,$J,""DESC"")"
-        . S KEYWORD="^TMP(TMPIND,$J,""KEYWORD"")"
-        . D DESC^PXRMEXU1(IENROOT(1),.DESL,$NA(@DESC),$NA(@KEYWORD))
-        K ^TMP($J,"CIND"),^TMP("PXRMEXRS",$J)
-        K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J)
-        Q
-        ;
-        ;=====================================================
-XMLOUT(IEN)     ;Write out the XML content of repository entry ien.
-        N LC,NLINES
-        S NLINES=$O(^PXD(811.8,IEN,100,""),-1)
-        F LC=1:1:NLINES W !,^PXD(811.8,IEN,100,LC,0)
-        Q
-        ;
+PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2. ;09/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;=====================================================
+FDA(IND,LC,TMPIND,FILENAME) ;Build the XML FDA output.
+ N FIELD,FILENUM,INDEX,INDEX0,JND,SIENS,WPC
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILEMAN_FDA>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
+ ;Get the file number.
+ S FILENUM=""
+ F  S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM)) Q:FILENUM=""  D
+ .;Get the source ien string.
+ . S SIENS=""
+ . F  S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS)) Q:SIENS=""  D
+ .. S INDEX0=FILENUM_";"_SIENS
+ ..;Get the field number and store the data.
+ .. S FIELD=""
+ .. F  S FIELD=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD)) Q:FIELD=""  D
+ ... S INDEX=INDEX0_";"_FIELD
+ ...;If there is another index past the field then this is a
+ ...;word-processing field.
+ ... I $D(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD))=11 D
+ .... S WPC=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD,""),-1)
+ .... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_"~WP-start~"_WPC
+ .... F JND=1:1:WPC D
+ ..... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD,JND)
+ ... E  S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_"~"_^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD)
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</FILEMAN_FDA>"
+ Q
+ ;
+ ;=====================================================
+IENROOT(IND,LC,TMPIND,FILENAME) ;Build the XML IEN_ROOT output.
+ N INDEX,VALUE
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<IEN_ROOT>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
+ S INDEX=0
+ F  S INDEX=$O(^TMP(TMPIND,$J,IND,FILENAME,INDEX)) Q:INDEX=""  D
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_U_^TMP(TMPIND,$J,IND,FILENAME,INDEX)
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</IEN_ROOT>"
+ Q
+ ;
+ ;=====================================================
+STOREPR(SUCCESS,RTM,TMPIND,EXTYPE) ;^TMP(TMPIND,$J contains data to be
+ ;stored in the repository. Routines will be found in
+ ;^TMP(TMPIND,$J,"ROUTINE",ROUTINE NAME,n) where n is the line number.
+ ;File entries will be found in ^TMP(TMPIND,$J,N,FILENAME,indexes).
+ ;This is output from the GETS^DIQ call. There are NUMF file entries.
+ ;Format and store it as XML in the repository.
+ N DATE,DTEST,FDA,FILENAME,FILENUM
+ N IENROOT,IND,JND,LC,LINE,NCMPNT,NEWFILE,NUMF,PT01,RNAME
+ N SIENS,SOURCE,TEMP,VERSN
+ ;If anything went wrong in the packing process then ^TMP(TMPIND,$J
+ ;will not exist.
+ I '$D(^TMP(TMPIND,$J)) S SUCCESS=0 Q
+ ;
+ K ^TMP($J,"CIND")
+ K ^TMP("PXRMEXRS",$J)
+ S ^TMP("PXRMEXRS",$J,1,0)="<?xml version=""1.0"" standalone=""yes""?>"
+ S ^TMP("PXRMEXRS",$J,2,0)="<REMINDER_EXCHANGE_FILE_ENTRY>"
+ S VERSN=^PXRM(800,1,"VERSION")
+ S ^TMP("PXRMEXRS",$J,3,0)="<PACKAGE_VERSION>"_VERSN_"</PACKAGE_VERSION>"
+ ;The pointer to the index will be on line 4 so leave room.
+ S LC=4
+ ;Save the source information.
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<SOURCE>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<NAME>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","REMINDER"))_"</NAME>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<USER>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","USER"))_"</USER>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<SITE>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","SITE"))_"</SITE>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<DATE_PACKED>"_^TMP(TMPIND,$J,"SRC","DATE")_"</DATE_PACKED>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</SOURCE>"
+ ;
+ ;Save the Exchange Type.
+ I EXTYPE="" S EXTYPE="REMINDER"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<EXCHANGE_TYPE>"_$$TOXML^PXRMEXU3(EXTYPE)_"</EXCHANGE_TYPE>"
+ ;
+ ;Save the description.
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<DESCRIPTION><![CDATA["
+ S IND=0
+ F  S IND=$O(^TMP(TMPIND,$J,"DESC",1,IND)) Q:+IND=0  D
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,"DESC",1,IND,0)
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]></DESCRIPTION>"
+ ;
+ ;Save the keywords or phrases.
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORDS>"
+ S IND=0
+ F  S IND=$O(^TMP(TMPIND,$J,"KEYWORD",1,IND)) Q:+IND=0  D
+ . S TEMP=^TMP(TMPIND,$J,"KEYWORD",1,IND,0)
+ . I TEMP["," D
+ .. F JND=1:1:$L(TEMP,",") D
+ ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3($P(TEMP,",",JND))_"</KEYWORD>"
+ . E  S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3(TEMP)_"</KEYWORD>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</KEYWORDS>"
+ ;
+ S NCMPNT=0
+ ;Do routines first.
+ S RNAME=""
+ F  S RNAME=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME)) Q:RNAME=""  D
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<M_ROUTINE>"
+ . S NCMPNT=NCMPNT+1
+ . S ^TMP($J,"CIND",NCMPNT,"M_ROUTINE_START")=LC
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<ROUTINE_NAME>"_RNAME_"</ROUTINE_NAME>"
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CODE>"
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
+ . S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_START")=LC+1
+ . S LINE=0
+ . F  S LINE=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME,LINE)) Q:LINE=""  D
+ .. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,"ROUTINE",RNAME,LINE,0)
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</CODE>"
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</M_ROUTINE>"
+ . S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_END")=LC-3
+ ;
+ ;Do file entries.
+ ;For word processing fields the first line is
+ ;file number;source ien string;field~WP-start~line count
+ ;The next line count lines are the WP data.
+ S NUMF=+$G(^TMP(TMPIND,$J,"NUMF"))
+ S FILENAME=""
+ F IND=1:1:NUMF D
+ . F  S FILENAME=$O(^TMP(TMPIND,$J,IND,FILENAME)) Q:FILENAME=""  D
+ .. I FILENAME["IENROOT" D
+ ... S NEWFILE=0
+ ... S IENROOT=1
+ .. E  D
+ ... S NEWFILE=1
+ ... S IENROOT=0
+ .. I NEWFILE D
+ ... S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,""))
+ ... S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,""))
+ ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILEMAN_FILE>"
+ ... S NCMPNT=NCMPNT+1
+ ... S ^TMP($J,"CIND",NCMPNT,"FILE_START")=LC
+ ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILE_NAME>"_$$TOXML^PXRMEXU3(FILENAME)_"</FILE_NAME>"
+ ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILE_NUMBER>"_FILENUM_"</FILE_NUMBER>"
+ ... S LC=LC+1,PT01=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,.01)
+ ... S ^TMP("PXRMEXRS",$J,LC,0)="<POINT_01>"_$$TOXML^PXRMEXU3(PT01)_"</POINT_01>"
+ ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<INTERNAL_ENTRY_NUMBER>"_+SIENS_"</INTERNAL_ENTRY_NUMBER>"
+ ... S ^TMP($J,"CIND",NCMPNT,"FDA_START")=LC+3
+ ... D FDA(IND,.LC,TMPIND,FILENAME)
+ ... S ^TMP($J,"CIND",NCMPNT,"FDA_END")=LC-2
+ ..;The ien root information always comes after the FDA.
+ .. I IENROOT D
+ ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_START")=LC+3
+ ... D IENROOT(IND,.LC,TMPIND,FILENAME)
+ ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_END")=LC-2
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</FILEMAN_FILE>"
+ ;Save the index.
+ S LC=LC+1,^TMP("PXRMEXRS",$J,4,0)="<INDEX_AT>"_LC_"</INDEX_AT>"
+ S ^TMP("PXRMEXRS",$J,LC,0)="<INDEX>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<NUMBER_OF_COMPONENTS>"_NCMPNT_"</NUMBER_OF_COMPONENTS>"
+ F IND=1:1:NCMPNT D
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<COMPONENT>"
+ . S JND=""
+ . F  S JND=$O(^TMP($J,"CIND",IND,JND)) Q:JND=""  D
+ .. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<"_JND_">"_^TMP($J,"CIND",IND,JND)_"</"_JND_">"
+ . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</COMPONENT>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</INDEX>"
+ S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</REMINDER_EXCHANGE_FILE_ENTRY>"
+ ;Establish the entry in the repository.
+ S RNAME=$P(RTM,U,2)
+ S SOURCE=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
+ S DATE=^TMP(TMPIND,$J,"SRC","DATE")
+ S FDA(811.8,"+1,",.01)=RNAME
+ S FDA(811.8,"+1,",.02)=SOURCE
+ S FDA(811.8,"+1,",.03)=DATE
+ S FDA(811.8,"+1,",115)=EXTYPE
+ D UPDATE^PXRMEXPU(.SUCCESS,.FDA,.IENROOT)
+ I SUCCESS D
+ . M ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXRS",$J)
+ .;Set the 0 node.
+ . S ^PXD(811.8,IENROOT(1),100,0)=U_811.801_U_LC_U_LC
+ .;Save the Exchange Type.
+ . S ^PXD(811.8,IENROOT(1),115)=$G(EXTYPE)
+ .;Create the description for this repository entry.
+ . N DATEP,DESC,DESL,KEYWORD,RNAME,SOURCE
+ . S DESL("RNAME")=^TMP(TMPIND,$J,"SRC","REMINDER")
+ . S DESL("SOURCE")=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
+ . S DESL("DATEP")=^TMP(TMPIND,$J,"SRC","DATE")
+ . S DESL("VRSN")=$G(^PXRM(800,1,"VERSION"))
+ . S DESC="^TMP(TMPIND,$J,""DESC"")"
+ . S KEYWORD="^TMP(TMPIND,$J,""KEYWORD"")"
+ . D DESC^PXRMEXU1(IENROOT(1),.DESL,$NA(@DESC),$NA(@KEYWORD))
+ K ^TMP($J,"CIND")
+ K ^TMP("PXRMEXRS",$J)
+ K ^TMP(TMPIND,$J)
+ Q
+ ;
+ ;=====================================================
+XMLOUT(IEN) ;Write out the XML content of repository entry ien.
+ N LC,NLINES
+ S NLINES=$O(^PXD(811.8,IEN,100,""),-1)
+ F LC=1:1:NLINES W !,^PXD(811.8,IEN,100,LC,0)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m

@@ -1 @@
-PXRMEXU4        ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;05/16/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;===============================================
-DLG(FDA,NAMECHG)        ;Check the dialog for renamed entries, called by
-        ;silent installer. KIDSDONE is newed in INSDLG^PXRMEXSI.
-        N ABBR,ACTION,ALIST,DNAM,IEN,IENS,FILENUM,FINDING,NEWNAM,OFINDING
-        N ORITEM,OORITEM,PT01,RESULT,RRG,SRC,WP
-        S IENS=$O(FDA(801.41,""))
-        ;Definition .01
-        S (PT01,DNAM)=FDA(801.41,IENS,.01)
-        I $D(NAMECHG(801.41,PT01)) D
-        .S (FDA(801.41,IENS,.01),DNAM)=NAMECHG(801.41,PT01)
-        ;
-        ;Build list of finding types
-        D BLDALIST^PXRMVPTR(801.4118,.01,.ALIST)
-        ;Plus field 15 files
-        ;S ALIST("MH")=601,ALIST("TX")=811.2
-        S ALIST("MH")=601.71,ALIST("TX")=811.2
-        S ALIST("WH")=790.404
-        ;Plus field 17 file
-        S ALIST("OI")=101.43
-        ;
-        ;Process SOURCE REMINDER
-        S SRC=$G(FDA(801.41,IENS,2))
-        I SRC]"" D
-        .S IEN=$$EXISTS^PXRMEXIU(811.9,SRC)
-        .I IEN=0 K FDA(801.41,IENS,2)
-        ;
-        ;Clear RESULT if not defined
-        S RESULT=$G(FDA(801.41,IENS,55))
-        I RESULT]"" D
-        .S IEN=$$EXISTS^PXRMEXIU(801.41,RESULT)
-        .I IEN=0 K FDA(801.41,IENS,55)
-        ;
-        ;Process ORDERABLE ITEM
-        S (ORITEM,OORITEM)=$G(FDA(801.41,IENS,17)),ACTION=""
-        I ORITEM'="" D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
-        .S PT01=ORITEM
-        .S ABBR="OI",FILENUM=$P(ALIST(ABBR),U)
-        .I $D(NAMECHG(FILENUM,PT01)) D
-        ..S ORITEM=NAMECHG(FILENUM,PT01)
-        ..S FDA(801.41,IENS,17)=ORITEM
-        .S IEN=+$$VFIND1^PXRMEXIU(ABBR_"."_ORITEM,.ALIST)
-        .I IEN=0 D
-        ..;Get replacement
-        ..N DIC,DIR,DUOUT,MSG,X,Y
-        ..S MSG(1)=" "
-        ..S MSG(2)="ORDERABLE ITEM  entry "_ORITEM_" does not exist."
-        ..D MES^XPDUTL(.MSG)
-        ..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
-        ..I ACTION="Q" Q
-        ..I ACTION="D" K FDA(801.41,IENS,17) Q
-        ..S DIC=FILENUM
-        ..S DIC(0)="AEMNQ"
-        ..S Y=-1
-        ..F  Q:+Y'=-1  D
-        ...;If this is being called during a KIDS install we need echoing on.
-        ...I $D(XPDNM) X ^%ZOSF("EON")
-        ...D ^DIC
-        ...I $D(XPDNM) X ^%ZOSF("EOFF")
-        ...;If this is being called during a KIDS install we need echoing on.
-        ...I $D(DUOUT) S Y="" Q
-        ...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
-        ..I Y="" S ACTION="Q" Q
-        ..S ORITEM=$P(Y,U,2)
-        ..S FDA(801.41,IENS,17)=ORITEM
-        .;Save the finding information for the history.
-        .I ORITEM'=OORITEM D
-        .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),ABBR_"."_OORITEM)=ABBR_"."_ORITEM
-        ;
-        ;Process FINDING ITEM
-        S (FINDING,OFINDING)=$G(FDA(801.41,IENS,15)),ACTION=""
-        I FINDING'="" D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
-        .S ABBR=$P(FINDING,".",1)
-        .S PT01=$P(FINDING,".",2)
-        .S FILENUM=$P(ALIST(ABBR),U,1)
-        .I $D(NAMECHG(FILENUM,PT01)) D
-        ..S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
-        ..S FDA(801.41,IENS,15)=FINDING
-        .S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
-        .I IEN=0 D
-        ..;Get replacement
-        ..N DIC,DIR,DUOUT,MSG,X,Y
-        ..S MSG(1)=" "
-        ..S MSG(2)="FINDING entry "_FINDING_" does not exist."
-        ..D MES^XPDUTL(.MSG)
-        ..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
-        ..I ACTION="Q" Q
-        ..I ACTION="D" K FDA(801.41,IENS,15) Q
-        ..S DIC=FILENUM
-        ..S DIC(0)="AEMNQ"
-        ..S Y=-1
-        ..F  Q:+Y'=-1  D
-        ...;If this is being called during a KIDS install we need echoing on.
-        ...I $D(XPDNM) X ^%ZOSF("EON")
-        ...D ^DIC
-        ...I $D(XPDNM) X ^%ZOSF("EOFF")
-        ...;If this is being called during a KIDS install we need echoing on.
-        ...I $D(DUOUT) S Y="" Q
-        ...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
-        ..I Y="" S ACTION="Q" Q
-        ..S FINDING=ABBR_"."_$P(Y,U,2)
-        ..S FDA(801.41,IENS,15)=FINDING
-        .;Save the finding information for the history.
-        .I FINDING'=OFINDING D
-        .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
-        .;Convert ICD9 codes to `ien format
-        .I $P(FINDING,".")="ICD9" S FDA(801.41,IENS,15)="ICD9."_$$ICD9(FINDING)
-        ;
-        ;Look for replacements of TIU templates.
-        I $D(NAMECHG(8927.1)) D
-        .S WP=$G(FDA(801.41,IENS,25))
-        .I WP'="" D TIURPL("{FLD:",WP,.NAMECHG,8927.1)
-        .S WP=$G(FDA(801.41,IENS,35))
-        ;
-        ;Process ADDITIONAL FINDINGS
-        S IENS="",ACTION=""
-        F  S IENS=$O(FDA(801.4118,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
-        . S (FINDING,OFINDING)=FDA(801.4118,IENS,.01)
-        . S ABBR=$P(FINDING,".",1)
-        . S PT01=$P(FINDING,".",2)
-        . S FILENUM=$P(ALIST(ABBR),U,1)
-        . I $D(NAMECHG(FILENUM,PT01)) D
-        .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
-        .. S FDA(801.4118,IENS,.01)=FINDING
-        . S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
-        . I IEN=0 D  Q:ACTION="Q"
-        ..;Get replacement
-        .. N DIC,DIR,DUOUT,MSG,X,Y
-        .. S MSG(1)=" "
-        .. S MSG(2)="ADDITIONAL FINDING entry "_FINDING_" does not exist."
-        .. D MES^XPDUTL(.MSG)
-        .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
-        .. I ACTION="S" S ACTION="Q"
-        .. I ACTION="Q" Q
-        .. I ACTION="D" K FDA(801.4118,IENS) Q
-        .. S DIC=FILENUM
-        .. S DIC(0)="AEMNQ"
-        .. S Y=-1
-        .. F  Q:+Y'=-1  D
-        ...;If this is being called during a KIDS install we need echoing on.
-        ... I $D(XPDNM) X ^%ZOSF("EON")
-        ... D ^DIC
-        ... I $D(XPDNM) X ^%ZOSF("EOFF")
-        ... I $D(DUOUT) S Y="" Q
-        ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
-        .. I Y="" S ACTION="Q" Q
-        .. S FINDING=ABBR_"."_$P(Y,U,2)
-        .. S FDA(801.4118,IENS,.01)=FINDING
-        . ;Save the finding information for the history.
-        . I FINDING'=OFINDING D
-        .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
-        . ;Convert ICD9 codes to `ien format
-        . I $P(FINDING,".")="ICD9" S FDA(801.4118,IENS,.01)=$$ICD9(FINDING)
-        ;
-        I ACTION="Q" S (PXRMDONE,KIDSDONE)=1 Q
-        ;Process DIALOG COMPONENT
-        S IENS="",ACTION=""
-        F  S IENS=$O(FDA(801.412,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
-        . S PT01=$G(FDA(801.412,IENS,2)) Q:PT01=""
-        . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
-        .I NEWNAM'="" D
-        .. S FDA(801.412,IENS,2)=NEWNAM,PT01=NEWNAM
-        .S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
-        .I IEN=0 D
-        ..;Get replacement
-        .. N DIC,DIR,DUOUT,MSG,X,Y
-        .. S MSG(1)=" "
-        .. S MSG(2)="COMPONENT DIALOG entry "_PT01_" does not exist."
-        .. D MES^XPDUTL(.MSG)
-        .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
-        .. I ACTION="S" S ACTION="Q"
-        .. I ACTION="Q" Q
-        .. I ACTION="D" K FDA(801.412,IENS) Q
-        .. S DIC=FILENUM
-        .. S DIC(0)="AEMNQ"
-        .. S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
-        .. S Y=-1
-        .. F  Q:+Y'=-1  D
-        ...;If this is being called during a KIDS install we need echoing on.
-        ... I $D(XPDNM) X ^%ZOSF("EON")
-        ... D ^DIC
-        ... I $D(XPDNM) X ^%ZOSF("EOFF")
-        ... I $D(DUOUT) S Y="" Q
-        ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
-        .. I Y="" S ACTION="Q" Q
-        .. I Y'="" S FDA(801.412,IENS,2)=$P(Y,U,2)
-        ;Process Result Groups
-        F  S IENS=$O(FDA(801.41121,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
-        . S PT01=$G(FDA(801.41121,IENS,.01)) Q:PT01=""
-        . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
-        .I NEWNAM'="" D
-        .. S FDA(801.41121,IENS,2)=NEWNAM,PT01=NEWNAM
-        .S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
-        .I IEN=0 D
-        ..;Get replacement
-        .. N DIC,DIR,DUOUT,MSG,X,Y
-        .. S MSG(1)=" "
-        .. S MSG(2)="RESULT GROUP entry "_PT01_" does not exist."
-        .. D MES^XPDUTL(.MSG)
-        .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
-        .. I ACTION="S" S ACTION="Q"
-        .. I ACTION="Q" Q
-        .. I ACTION="D" K FDA(801.41121,IENS) Q
-        .. S DIC=FILENUM
-        .. S DIC(0)="AEMNQ"
-        .. S DIC("S")="I ""S""[$P(^PXRMD(801.41,Y,0),U,4)"
-        .. S Y=-1
-        .. F  Q:+Y'=-1  D
-        ...;If this is being called during a KIDS install we need echoing on.
-        ... I $D(XPDNM) X ^%ZOSF("EON")
-        ... D ^DIC
-        ... I $D(XPDNM) X ^%ZOSF("EOFF")
-        ... I $D(DUOUT) S Y="" Q
-        ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
-        .. I Y="" S ACTION="Q" Q
-        .. I Y'="" S FDA(801.41121,IENS,.01)=$P(Y,U,2)
-        Q
-        ;
-        ;===============================================
-        ;Convert ICD9 codes to `ien format
-ICD9(CODE)      ;
-        N IEN
-        S IEN=$$FIND1^DIC(80,"","AMX",$P(CODE,".",2,99))
-        I 'IEN Q ""
-        Q "`"_IEN
-        ;
-        ;===============================================
-TIURPL(SRCH,WP,NAMEGHC,FILENUM) ;Replace TIU templates whose names have
-        ;changed.
-        N IND,RS,TEXT,TS,TYPE
-        I FILENUM=8927.1 S TYPE="TIU TEMPLATE"
-        E  S TYPE="TIU OBJECT"
-        S IND=1
-        F  S TEXT=$G(@WP@(IND)) Q:TEXT=""  D
-        .I TEXT[SRCH D
-        ..S TS=""
-        ..F  S TS=$O(NAMECHG(FILENUM,TS)) Q:TS=""  D
-        ...S RS=NAMECHG(FILENUM,TS) Q:TEXT'[TS
-        ...S @WP@(IND)=$$STRREP^PXRMUTIL(TEXT,TS,RS)
-        ...;Save the replacement information for the history.
-        ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS)=RS
-        ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS,DNAM)=""
-        .S IND=IND+1
-        Q
-        ;
+PXRMEXU4 ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;01/19/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;===============================================
+DLG(FDA,NAMECHG) ;Check the dialog for renamed entries, called by
+ ;silent installer. KIDSDONE is newed in INSDLG^PXRMEXSI.
+ N ABBR,ACTION,ALIST,DNAM,IEN,IENS,FILENUM,FINDING,NEWNAM,OFINDING
+ N ORITEM,OORITEM,PT01,RESULT,RRG,SRC,WP
+ S IENS=$O(FDA(801.41,""))
+ ;Definition .01
+ S (PT01,DNAM)=FDA(801.41,IENS,.01)
+ I $D(NAMECHG(801.41,PT01)) D
+ .S (FDA(801.41,IENS,.01),DNAM)=NAMECHG(801.41,PT01)
+ ;
+ ;Build list of finding types
+ D BLDALIST^PXRMVPTR(801.4118,.01,.ALIST)
+ ;Plus field 15 files
+ S ALIST("MH")=601,ALIST("TX")=811.2
+ S ALIST("WH")=790.404
+ ;Plus field 17 file
+ S ALIST("OI")=101.43
+ ;
+ ;Process SOURCE REMINDER
+ S SRC=$G(FDA(801.41,IENS,2))
+ I SRC]"" D
+ .S IEN=$$EXISTS^PXRMEXIU(811.9,SRC)
+ .I IEN=0 K FDA(801.41,IENS,2)
+ ;
+ ;Clear RESULT if not defined
+ S RESULT=$G(FDA(801.41,IENS,55))
+ I RESULT]"" D
+ .S IEN=$$EXISTS^PXRMEXIU(801.41,RESULT)
+ .I IEN=0 K FDA(801.41,IENS,55)
+ ;
+ ;Process ORDERABLE ITEM
+ S (ORITEM,OORITEM)=$G(FDA(801.41,IENS,17)),ACTION=""
+ I ORITEM'="" D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
+ .S PT01=ORITEM
+ .S ABBR="OI",FILENUM=$P(ALIST(ABBR),U)
+ .I $D(NAMECHG(FILENUM,PT01)) D
+ ..S ORITEM=NAMECHG(FILENUM,PT01)
+ ..S FDA(801.41,IENS,17)=ORITEM
+ .S IEN=+$$VFIND1^PXRMEXIU(ABBR_"."_ORITEM,.ALIST)
+ .I IEN=0 D
+ ..;Get replacement
+ ..N DIC,DIR,DUOUT,MSG,X,Y
+ ..S MSG(1)=" "
+ ..S MSG(2)="ORDERABLE ITEM  entry "_ORITEM_" does not exist."
+ ..D MES^XPDUTL(.MSG)
+ ..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
+ ..I ACTION="Q" Q
+ ..I ACTION="D" K FDA(801.41,IENS,17) Q
+ ..S DIC=FILENUM
+ ..S DIC(0)="AEMNQ"
+ ..S Y=-1
+ ..F  Q:+Y'=-1  D
+ ...;If this is being called during a KIDS install we need echoing on.
+ ...I $D(XPDNM) X ^%ZOSF("EON")
+ ...D ^DIC
+ ...I $D(XPDNM) X ^%ZOSF("EOFF")
+ ...;If this is being called during a KIDS install we need echoing on.
+ ...I $D(DUOUT) S Y="" Q
+ ...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
+ ..I Y="" S ACTION="Q" Q
+ ..S ORITEM=$P(Y,U,2)
+ ..S FDA(801.41,IENS,17)=ORITEM
+ .;Save the finding information for the history.
+ .I ORITEM'=OORITEM D
+ .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),ABBR_"."_OORITEM)=ABBR_"."_ORITEM
+ ;
+ ;Process FINDING ITEM
+ S (FINDING,OFINDING)=$G(FDA(801.41,IENS,15)),ACTION=""
+ I FINDING'="" D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
+ .S ABBR=$P(FINDING,".",1)
+ .S PT01=$P(FINDING,".",2)
+ .S FILENUM=$P(ALIST(ABBR),U,1)
+ .I $D(NAMECHG(FILENUM,PT01)) D
+ ..S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+ ..S FDA(801.41,IENS,15)=FINDING
+ .S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
+ .I IEN=0 D
+ ..;Get replacement
+ ..N DIC,DIR,DUOUT,MSG,X,Y
+ ..S MSG(1)=" "
+ ..S MSG(2)="FINDING entry "_FINDING_" does not exist."
+ ..D MES^XPDUTL(.MSG)
+ ..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
+ ..I ACTION="Q" Q
+ ..I ACTION="D" K FDA(801.41,IENS,15) Q
+ ..S DIC=FILENUM
+ ..S DIC(0)="AEMNQ"
+ ..S Y=-1
+ ..F  Q:+Y'=-1  D
+ ...;If this is being called during a KIDS install we need echoing on.
+ ...I $D(XPDNM) X ^%ZOSF("EON")
+ ...D ^DIC
+ ...I $D(XPDNM) X ^%ZOSF("EOFF")
+ ...;If this is being called during a KIDS install we need echoing on.
+ ...I $D(DUOUT) S Y="" Q
+ ...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
+ ..I Y="" S ACTION="Q" Q
+ ..S FINDING=ABBR_"."_$P(Y,U,2)
+ ..S FDA(801.41,IENS,15)=FINDING
+ .;Save the finding information for the history.
+ .I FINDING'=OFINDING D
+ .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
+ .;Convert ICD9 codes to `ien format
+ .I $P(FINDING,".")="ICD9" S FDA(801.41,IENS,15)="ICD9."_$$ICD9(FINDING)
+ ;
+ ;Look for replacements of TIU templates.
+ I $D(NAMECHG(8927.1)) D
+ .S WP=$G(FDA(801.41,IENS,25))
+ .I WP'="" D TIURPL("{FLD:",WP,.NAMECHG,8927.1)
+ .S WP=$G(FDA(801.41,IENS,35))
+ ;
+ ;Process ADDITIONAL FINDINGS
+ S IENS="",ACTION=""
+ F  S IENS=$O(FDA(801.4118,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
+ . S (FINDING,OFINDING)=FDA(801.4118,IENS,.01)
+ . S ABBR=$P(FINDING,".",1)
+ . S PT01=$P(FINDING,".",2)
+ . S FILENUM=$P(ALIST(ABBR),U,1)
+ . I $D(NAMECHG(FILENUM,PT01)) D
+ .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
+ .. S FDA(801.4118,IENS,.01)=FINDING
+ . S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
+ . I IEN=0 D  Q:ACTION="Q"
+ ..;Get replacement
+ .. N DIC,DIR,DUOUT,MSG,X,Y
+ .. S MSG(1)=" "
+ .. S MSG(2)="ADDITIONAL FINDING entry "_FINDING_" does not exist."
+ .. D MES^XPDUTL(.MSG)
+ .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
+ .. I ACTION="S" S ACTION="Q"
+ .. I ACTION="Q" Q
+ .. I ACTION="D" K FDA(801.4118,IENS) Q
+ .. S DIC=FILENUM
+ .. S DIC(0)="AEMNQ"
+ .. S Y=-1
+ .. F  Q:+Y'=-1  D
+ ...;If this is being called during a KIDS install we need echoing on.
+ ... I $D(XPDNM) X ^%ZOSF("EON")
+ ... D ^DIC
+ ... I $D(XPDNM) X ^%ZOSF("EOFF")
+ ... I $D(DUOUT) S Y="" Q
+ ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
+ .. I Y="" S ACTION="Q" Q
+ .. S FINDING=ABBR_"."_$P(Y,U,2)
+ .. S FDA(801.4118,IENS,.01)=FINDING
+ . ;Save the finding information for the history.
+ . I FINDING'=OFINDING D
+ .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
+ . ;Convert ICD9 codes to `ien format
+ . I $P(FINDING,".")="ICD9" S FDA(801.4118,IENS,.01)=$$ICD9(FINDING)
+ ;
+ I ACTION="Q" S (PXRMDONE,KIDSDONE)=1 Q
+ ;Process DIALOG COMPONENT
+ S IENS="",ACTION=""
+ F  S IENS=$O(FDA(801.412,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
+ . S PT01=$G(FDA(801.412,IENS,2)) Q:PT01=""
+ . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
+ .I NEWNAM'="" D
+ .. S FDA(801.412,IENS,2)=NEWNAM,PT01=NEWNAM
+ .S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
+ .I IEN=0 D
+ ..;Get replacement
+ .. N DIC,DIR,DUOUT,MSG,X,Y
+ .. S MSG(1)=" "
+ .. S MSG(2)="COMPONENT DIALOG entry "_PT01_" does not exist."
+ .. D MES^XPDUTL(.MSG)
+ .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
+ .. I ACTION="S" S ACTION="Q"
+ .. I ACTION="Q" Q
+ .. I ACTION="D" K FDA(801.412,IENS) Q
+ .. S DIC=FILENUM
+ .. S DIC(0)="AEMNQ"
+ .. S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
+ .. S Y=-1
+ .. F  Q:+Y'=-1  D
+ ...;If this is being called during a KIDS install we need echoing on.
+ ... I $D(XPDNM) X ^%ZOSF("EON")
+ ... D ^DIC
+ ... I $D(XPDNM) X ^%ZOSF("EOFF")
+ ... I $D(DUOUT) S Y="" Q
+ ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
+ .. I Y="" S ACTION="Q" Q
+ .. I Y'="" S FDA(801.412,IENS,2)=$P(Y,U,2)
+ Q
+ ;
+ ;===============================================
+ ;Convert ICD9 codes to `ien format
+ICD9(CODE) ;
+ N IEN
+ S IEN=$$FIND1^DIC(80,"","AMX",$P(CODE,".",2,99))
+ I 'IEN Q ""
+ Q "`"_IEN
+ ;
+ ;===============================================
+TIURPL(SRCH,WP,NAMEGHC,FILENUM) ;Replace TIU templates whose names have
+ ;changed.
+ N IND,RS,TEXT,TS,TYPE
+ I FILENUM=8927.1 S TYPE="TIU TEMPLATE"
+ E  S TYPE="TIU OBJECT"
+ S IND=1
+ F  S TEXT=$G(@WP@(IND)) Q:TEXT=""  D
+ .I TEXT[SRCH D
+ ..S TS=""
+ ..F  S TS=$O(NAMECHG(FILENUM,TS)) Q:TS=""  D
+ ...S RS=NAMECHG(FILENUM,TS) Q:TEXT'[TS
+ ...S @WP@(IND)=$$STRREP^PXRMUTIL(TEXT,TS,RS)
+ ...;Save the replacement information for the history.
+ ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS)=RS
+ ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS,DNAM)=""
+ .S IND=IND+1
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m

@@ -1 @@
-PXRMFF  ;SLC/PKR - Clinical Reminders function finding evaluation. ;3/29/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;===========================================
-EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings.
-        N FFIND,FFN,FILIST,FN,FUN,FUNIND,FUNN,FVALUE,JND
-        N LOGIC,NL,ROUTINE,TEMP
-        I '$D(DEFARR(25)) Q
-        S FFN="FF"
-        F  S FFN=$O(DEFARR(25,FFN)) Q:FFN'["FF"  D
-        . K FN
-        . S FUNIND=0
-        . F  S FUNIND=+$O(DEFARR(25,FFN,5,FUNIND)) Q:FUNIND=0  D
-        .. S FUNN=$P(DEFARR(25,FFN,5,FUNIND,0),U,1)
-        .. S FUN=$P(DEFARR(25,FFN,5,FUNIND,0),U,2)
-        .. S TEMP=^PXRMD(802.4,FUN,0)
-        .. S ROUTINE=$P(TEMP,U,2,3)_"(.FILIST,.FIEVAL,.FVALUE)"
-        .. K FILIST
-        .. S (JND,NL)=0
-        .. F  S JND=+$O(DEFARR(25,FFN,5,FUNIND,20,JND)) Q:JND=0  D
-        ... S NL=NL+1
-        ... S FILIST(NL)=DEFARR(25,FFN,5,FUNIND,20,JND,0)
-        .. S FILIST(0)=NL
-        .. D @ROUTINE
-        .. S FN(FUNIND)=FVALUE
-        . S LOGIC=$G(DEFARR(25,FFN,10))
-        . S LOGIC=$S(LOGIC'="":LOGIC,1:0)
-        . I @LOGIC
-        . S FIEVAL(FFN)=$T
-        . S FIEVAL(FFN,"NUMBER")=$P(FFN,"FF",2)
-        . S FIEVAL(FFN,"FINDING")=$G(FUN)_";PXRMD(802.4,"
-        Q
-        ;
-        ;===========================================
-EVALPL(DEFARR,FFIND,PLIST)      ;Build a list of patients based on a function
-        ;finding.
-        N COUNT,DAS,DATE,DFN
-        N FI,FIEVAL,FIEVT,FIL,FILIST,FILENUM,FINDPA,FN
-        N FUN,FUNNM,FUNN,FUNNUM,FVALUE
-        N IND,ITEM,JND,LOGIC,LNAME,NFI,NFUN,ROUTINE,TEMP,TERMARR,UNIQFIL
-        S LOGIC=DEFARR(25,FFIND,10)
-        I LOGIC="" Q
-        ;Build the list of functions and findings used by the function finding.
-        S (FUNNUM,NFUN)=0
-        F  S FUNNUM=+$O(DEFARR(25,FFIND,5,FUNNUM)) Q:FUNNUM=0  D
-        . S NFUN=NFUN+1
-        . S FUNN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,1)
-        . S FUN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,2)
-        . S TEMP=^PXRMD(802.4,FUN,0)
-        . S ROUTINE(NFUN)=$P(TEMP,U,2,3)_"(.FIL,.FIEVAL,.FVALUE)"
-        . S (FI,NFI)=0
-        . F  S FI=+$O(DEFARR(25,FFIND,5,FUNNUM,20,FI)) Q:FI=0  D
-        .. S NFI=NFI+1,FILIST(NFUN,NFI)=DEFARR(25,FFIND,5,FUNNUM,20,FI,0)
-        . S FILIST(NFUN,0)=NFI
-        ;A finding may be used in more than one function in the function
-        ;finding so build a list of the unique findings.
-        F IND=1:1:NFUN D
-        . F JND=1:1:FILIST(IND,0) D
-        .. S TEMP=$P(DEFARR(20,FILIST(IND,JND),0),U,1)
-        .. S ITEM=$P(TEMP,";",1)
-        .. S FILENUM=$$GETFNUM^PXRMDATA($P(TEMP,";",2))
-        .. S UNIQFIL(FILIST(IND,JND))=""
-        K ^TMP($J,"PXRMFFDFN")
-        S IND=0
-        F  S IND=$O(UNIQFIL(IND)) Q:IND=""  D
-        . S FINDPA(0)=DEFARR(20,IND,0)
-        . S FINDPA(3)=DEFARR(20,IND,3)
-        . S FINDPA(10)=DEFARR(20,IND,10)
-        . S FINDPA(11)=DEFARR(20,IND,11)
-        . D GENTERM^PXRMPLST(FINDPA(0),IND,.TERMARR)
-        . S LNAME(IND)="PXRMFF"_IND
-        . K ^TMP($J,LNAME(IND))
-        . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,LNAME(IND))
-        .;Get rid of the false part of the list.
-        . K ^TMP($J,LNAME(IND),0)
-        .;Build a complete list of patients.
-        . S DFN=0
-        . F  S DFN=$O(^TMP($J,LNAME(IND),1,DFN)) Q:DFN=""  S ^TMP($J,"PXRMFFDFN",DFN)=""
-        ;Evaluate the function finding for each patient. If the function
-        ;finding is true then add the patient to PLIST.
-        S DFN=0
-        F  S DFN=$O(^TMP($J,"PXRMFFDFN",DFN)) Q:DFN=""  D
-        . K FIEVAL
-        . S IND=""
-        . F  S IND=$O(UNIQFIL(IND)) Q:IND=""  D
-        .. S FIEVAL(IND)=0
-        .. S ITEM=""
-        .. F  S ITEM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM)) Q:ITEM=""  D
-        ... S COUNT=0
-        ... F  S COUNT=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT)) Q:COUNT=""  D
-        .... S FILENUM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,""))
-        .... S TEMP=^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,FILENUM)
-        .... S DAS=$P(TEMP,U,1)
-        .... S DATE=$P(TEMP,U,2)
-        .... K FIEVT
-        .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
-        .... M FIEVAL(IND,COUNT)=FIEVT
-        .... S FIEVAL(IND,COUNT,"DATE")=DATE,FIEVAL(IND,COUNT)=1
-        .;Save the top level results for each finding.
-        . S IND=0
-        . F  S IND=$O(FIEVAL(IND)) Q:IND=""  D
-        .. K FIEVT M FIEVT=FIEVAL(IND)
-        .. S NFI=+$O(FIEVT(""),-1)
-        .. D SFRES^PXRMUTIL(-1,NFI,.FIEVT)
-        .. K FIEVAL(IND) M FIEVAL(IND)=FIEVT
-        .;Evaluate the function finding for this patient.
-        . K FN
-        . F IND=1:1:NFUN D
-        .. K FIL M FIL=FILIST(IND)
-        .. D @ROUTINE(IND)
-        .. S FN(IND)=FVALUE
-        . I @LOGIC S ^TMP($J,PLIST,1,DFN,1,FFIND)=""
-        ;Clean up.
-        K ^TMP($J,"PXRMFFDFN")
-        S IND=""
-        F  S IND=$O(UNIQFIL(IND)) Q:IND=""  K ^TMP($J,LNAME(IND))
-        Q
-        ;
-        ;===========================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        ;None currently defined.
-        Q
-        ;
-        ;===========================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output. None currently defined.
-        Q
-        ;
+PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;===========================================
+EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings.
+ N FFIND,FFN,FILIST,FN,FUN,FUNIND,FUNN,FVALUE,JND
+ N LOGIC,NL,ROUTINE,TEMP
+ I '$D(DEFARR(25)) Q
+ S FFN="FF"
+ F  S FFN=$O(DEFARR(25,FFN)) Q:FFN'["FF"  D
+ . K FN
+ . S FUNIND=0
+ . F  S FUNIND=+$O(DEFARR(25,FFN,5,FUNIND)) Q:FUNIND=0  D
+ .. S FUNN=$P(DEFARR(25,FFN,5,FUNIND,0),U,1)
+ .. S FUN=$P(DEFARR(25,FFN,5,FUNIND,0),U,2)
+ .. S TEMP=^PXRMD(802.4,FUN,0)
+ .. S ROUTINE=$P(TEMP,U,2,3)_"(.FILIST,.FIEVAL,.FVALUE)"
+ .. K FILIST
+ .. S (JND,NL)=0
+ .. F  S JND=+$O(DEFARR(25,FFN,5,FUNIND,20,JND)) Q:JND=0  D
+ ... S NL=NL+1
+ ... S FILIST(NL)=DEFARR(25,FFN,5,FUNIND,20,JND,0)
+ .. S FILIST(0)=NL
+ .. D @ROUTINE
+ .. S FN(FUNIND)=FVALUE
+ . S LOGIC=$G(DEFARR(25,FFN,10))
+ . S LOGIC=$S(LOGIC'="":LOGIC,1:0)
+ . I @LOGIC
+ . S FIEVAL(FFN)=$T
+ . S FIEVAL(FFN,"NUMBER")=$P(FFN,"FF",2)
+ . S FIEVAL(FFN,"FINDING")=$G(FUN)_";PXRMD(802.4,"
+ Q
+ ;
+ ;===========================================
+EVALPL(DEFARR,FFIND,PLIST) ;Build a list of patients based on a function
+ ;finding.
+ N COUNT,DAS,DATE,DFN
+ N FI,FIEVAL,FIEVT,FIL,FILIST,FILENUM,FINDPA,FN
+ N FUN,FUNNM,FUNN,FUNNUM,FVALUE
+ N IND,ITEM,JND,LOGIC,LNAME,NFI,NFUN,ROUTINE,TEMP,TERMARR,UNIQFIL
+ S LOGIC=DEFARR(25,FFIND,10)
+ I LOGIC="" Q
+ ;Build the list of functions and findings used by the function finding.
+ S (FUNNUM,NFUN)=0
+ F  S FUNNUM=+$O(DEFARR(25,FFIND,5,FUNNUM)) Q:FUNNUM=0  D
+ . S NFUN=NFUN+1
+ . S FUNN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,1)
+ . S FUN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,2)
+ . S TEMP=^PXRMD(802.4,FUN,0)
+ . S ROUTINE(NFUN)=$P(TEMP,U,2,3)_"(.FIL,.FIEVAL,.FVALUE)"
+ . S (FI,NFI)=0
+ . F  S FI=+$O(DEFARR(25,FFIND,5,FUNNUM,20,FI)) Q:FI=0  D
+ .. S NFI=NFI+1,FILIST(NFUN,NFI)=DEFARR(25,FFIND,5,FUNNUM,20,FI,0)
+ . S FILIST(NFUN,0)=NFI
+ ;A finding may be used in more than one function in the function
+ ;finding so build a list of the unique findings.
+ F IND=1:1:NFUN D
+ . F JND=1:1:FILIST(IND,0) D
+ .. S TEMP=$P(DEFARR(20,FILIST(IND,JND),0),U,1)
+ .. S ITEM=$P(TEMP,";",1)
+ .. S FILENUM=$$GETFNUM^PXRMDATA($P(TEMP,";",2))
+ .. S UNIQFIL(FILIST(IND,JND))=""
+ K ^TMP($J,"PXRMFFDFN")
+ S IND=0
+ F  S IND=$O(UNIQFIL(IND)) Q:IND=""  D
+ . S FINDPA(0)=DEFARR(20,IND,0)
+ . S FINDPA(3)=DEFARR(20,IND,3)
+ . S FINDPA(10)=DEFARR(20,IND,10)
+ . S FINDPA(11)=DEFARR(20,IND,11)
+ . D GENTERM^PXRMPLST(FINDPA(0),IND,.TERMARR)
+ . S LNAME(IND)="PXRMFF"_IND
+ . K ^TMP($J,LNAME(IND))
+ . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,LNAME(IND))
+ .;Get rid of the false part of the list.
+ . K ^TMP($J,LNAME(IND),0)
+ .;Build a complete list of patients.
+ . S DFN=0
+ . F  S DFN=$O(^TMP($J,LNAME(IND),1,DFN)) Q:DFN=""  S ^TMP($J,"PXRMFFDFN",DFN)=""
+ ;Evaluate the function finding for each patient. If the function
+ ;finding is true then add the patient to PLIST.
+ S DFN=0
+ F  S DFN=$O(^TMP($J,"PXRMFFDFN",DFN)) Q:DFN=""  D
+ . K FIEVAL
+ . S IND=""
+ . F  S IND=$O(UNIQFIL(IND)) Q:IND=""  D
+ .. S FIEVAL(IND)=0
+ .. S ITEM=""
+ .. F  S ITEM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM)) Q:ITEM=""  D
+ ... S COUNT=0
+ ... F  S COUNT=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT)) Q:COUNT=""  D
+ .... S FILENUM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,""))
+ .... S TEMP=^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,FILENUM)
+ .... S DAS=$P(TEMP,U,1)
+ .... S DATE=$P(TEMP,U,2)
+ .... K FIEVT
+ .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
+ .... M FIEVAL(IND,COUNT)=FIEVT
+ .... S FIEVAL(IND,COUNT,"DATE")=DATE,FIEVAL(IND,COUNT)=1
+ .;Save the top level results for each finding.
+ . S IND=0
+ . F  S IND=$O(FIEVAL(IND)) Q:IND=""  D
+ .. K FIEVT M FIEVT=FIEVAL(IND)
+ .. S NFI=+$O(FIEVT(""),-1)
+ .. D SFRES^PXRMUTIL(-1,NFI,.FIEVT)
+ .. K FIEVAL(IND) M FIEVAL(IND)=FIEVT
+ .;Evaluate the function finding for this patient.
+ . K FN
+ . F IND=1:1:NFUN D
+ .. K FIL M FIL=FILIST(IND)
+ .. D @ROUTINE(IND)
+ .. S FN(IND)=FVALUE
+ . I @LOGIC S ^TMP($J,PLIST,1,DFN,1,FFIND)=""
+ ;Clean up.
+ K ^TMP($J,"PXRMFFDFN")
+ S IND=""
+ F  S IND=$O(UNIQFIL(IND)) Q:IND=""  K ^TMP($J,LNAME(IND))
+ Q
+ ;
+ ;===========================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ ;None currently defined.
+ Q
+ ;
+ ;===========================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output. None currently defined.
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m

@@ -1 @@
-PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;09/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;============================================
-COUNT(LIST,FIEVAL,COUNT)        ;
-        N IND,JND,KND
-        S COUNT=0
-        F IND=1:1:LIST(0) D
-        . S JND=LIST(IND),KND=0
-        . F  S KND=+$O(FIEVAL(JND,KND)) Q:KND=0  D
-        .. I FIEVAL(JND,KND) S COUNT=COUNT+1
-        Q
-        ;
-        ;===========================================
-DIFFDATE(LIST,FIEVAL,DIFF)      ;Return the difference in days between the
-        ;first two findings in the list.
-        I LIST(0)<2 S DIFF=2 Q
-        N DATE1,DATE2,DAYS,IND,JND
-        S DATE1=+$G(FIEVAL(LIST(1),"DATE"))
-        S DATE2=+$G(FIEVAL(LIST(2),"DATE"))
-        S DAYS=$$FMDIFF^XLFDT(DATE1,DATE2)
-        S DIFF=$S(DAYS<0:-DAYS,1:DAYS)
-        Q
-        ;
-        ;===========================================
-DUR(LIST,FIEVAL,DUR)    ;
-        N EDT,IND,JND,KND,SDT
-        F IND=1:1:LIST(0) D
-        . S JND=LIST(IND)
-        . I FIEVAL(JND)=0 S (EDT,SDT)=0 Q
-        .;Check for finding with start and stop date.
-        . I $D(FIEVAL(JND,"START DATE")) D
-        .. S SDT=+$G(FIEVAL(JND,"START DATE"))
-        .. S EDT=+$G(FIEVAL(JND,"STOP DATE"))
-        .. I EDT=0 S EDT=+$G(FIEVAL(JND,"DATE"))
-        . E  D
-        ..;Get start and stop for multiple occurrences.
-        .. S KND=$O(FIEVAL(JND,"A"),-1)
-        .. S EDT=$S(KND="":0,1:$G(FIEVAL(JND,KND,"DATE")))
-        .. S KND=+$O(FIEVAL(JND,""))
-        .. S SDT=$S(KND=0:0,1:$G(FIEVAL(JND,KND,"DATE")))
-        ;Return the duration in days.
-        S DUR=$$FMDIFF^XLFDT(EDT,SDT)
-        I DUR<0 S DUR=-DUR
-        Q
-        ;
-        ;============================================
-FI(LIST,FIEVAL,LV)      ;Given a regular finding return its true/false value.
-        S LV=FIEVAL(LIST(1))
-        Q
-        ;
-        ;============================================
-MAXDATE(LIST,FIEVAL,MAXDATE)    ;Given a list of findings return the maximum
-        ;date. This will be the newest date.
-        N DATE,IND
-        S MAXDATE=0
-        F IND=1:1:LIST(0) D
-        . S DATE=$G(FIEVAL(LIST(IND),"DATE"))
-        . I DATE>MAXDATE S MAXDATE=DATE
-        Q
-        ;
-        ;============================================
-MINDATE(LIST,FIEVAL,MINDATE)    ;Given a list of findings return the minimum
-        ;date. This will be the oldest non-null or zero date.
-        N DATE,IND
-        S MINDATE=9991231
-        F IND=1:1:LIST(0) D
-        . S DATE=$G(FIEVAL(LIST(IND),"DATE"))
-        . I DATE<MINDATE S MINDATE=DATE
-        I MINDATE=9991231 S MINDATE=0
-        Q
-        ;
-        ;============================================
-MRD(LIST,FIEVAL,MRD)    ;Given a list of findings return the most recent
-        ;finding date from the list.
-        N DATE,IND
-        S MRD=0
-        F IND=1:1:LIST(0) D
-        . S DATE=$G(FIEVAL(LIST(IND),"DATE"))
-        . I DATE>MRD S MRD=DATE
-        Q
-        ;
-        ;============================================
-NUMERIC(LIST,FIEVAL,VALUE)      ;Given a finding, return the first numeric
-        ;portion of one of the "CSUB" values. Based on original work
-        ;by R. Silverman.
-        S VALUE=$G(FIEVAL(LIST(1),LIST(2),LIST(3)))
-        S VALUE=$$FIRSTNUM(VALUE)
-        Q
-        ;
-FIRSTNUM(STRING)        ;return the first numeric portion of a string.
-        N CHAR,DONE,IND,NUMBER,NUMERIC
-        S NUMERIC="+-.1234567890"
-        S STRING=$TR(STRING," ")
-        S DONE=0,IND=0,NUMBER=""
-        F  Q:DONE  D
-        . S IND=IND+1,CHAR=$E(STRING,IND)
-        . I CHAR="" S DONE=1 Q
-        . I NUMERIC[CHAR S NUMBER=NUMBER_CHAR
-        . I NUMBER'="",NUMERIC'[CHAR S DONE=1
-        Q +NUMBER
-        ;
-        ;============================================
-VALUE(LIST,FIEVAL,VALUE)        ;Given a finding return one of its "CSUB"
-        ;values.
-        S VALUE=$G(FIEVAL(LIST(1),LIST(2),LIST(3)))
-        Q
-        ;
+PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;06/23/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;============================================
+COUNT(LIST,FIEVAL,COUNT) ;
+ N IND,JND,KND
+ S COUNT=0
+ F IND=1:1:LIST(0) D
+ . S JND=LIST(IND),KND=0
+ . F  S KND=+$O(FIEVAL(JND,KND)) Q:KND=0  D
+ .. I FIEVAL(JND,KND) S COUNT=COUNT+1
+ Q
+ ;
+ ;===========================================
+DIFFDATE(LIST,FIEVAL,DIFF) ;Return the difference in days between the
+ ;first two findings in the list.
+ I LIST(0)<2 S DIFF=2 Q
+ N DATE1,DATE2,DAYS,IND,JND
+ S DATE1=+$G(FIEVAL(LIST(1),"DATE"))
+ S DATE2=+$G(FIEVAL(LIST(2),"DATE"))
+ S DAYS=$$FMDIFF^XLFDT(DATE1,DATE2)
+ S DIFF=$S(DAYS<0:-DAYS,1:DAYS)
+ Q
+ ;
+ ;===========================================
+DUR(LIST,FIEVAL,DUR) ;
+ N EDT,IND,JND,KND,SDT
+ F IND=1:1:LIST(0) D
+ . S JND=LIST(IND)
+ . I FIEVAL(JND)=0 S (EDT,SDT)=0 Q
+ .;Check for finding with start and stop date.
+ . I $D(FIEVAL(JND,"START DATE")) D
+ .. S SDT=+$G(FIEVAL(JND,"START DATE"))
+ .. S EDT=+$G(FIEVAL(JND,"STOP DATE"))
+ .. I EDT=0 S EDT=+$G(FIEVAL(JND,"DATE"))
+ . E  D
+ ..;Get start and stop for multiple occurrences.
+ .. S KND=$O(FIEVAL(JND,"A"),-1)
+ .. S EDT=$S(KND="":0,1:$G(FIEVAL(JND,KND,"DATE")))
+ .. S KND=+$O(FIEVAL(JND,""))
+ .. S SDT=$S(KND=0:0,1:$G(FIEVAL(JND,KND,"DATE")))
+ ;Return the duration in days.
+ S DUR=$$FMDIFF^XLFDT(EDT,SDT)
+ I DUR<0 S DUR=-DUR
+ Q
+ ;
+ ;============================================
+FI(LIST,FIEVAL,LV) ;Given a regular finding return its true/false value.
+ S LV=FIEVAL(LIST(1))
+ Q
+ ;
+ ;============================================
+MAXDATE(LIST,FIEVAL,MAXDATE) ;Given a list of findings return the maximum
+ ;date. This will be the newest date.
+ N DATE,IND
+ S MAXDATE=0
+ F IND=1:1:LIST(0) D
+ . S DATE=$G(FIEVAL(LIST(IND),"DATE"))
+ . I DATE>MAXDATE S MAXDATE=DATE
+ Q
+ ;
+ ;============================================
+MINDATE(LIST,FIEVAL,MINDATE) ;Given a list of findings return the minimum
+ ;date. This will be the oldest non-null or zero date.
+ N DATE,IND
+ S MINDATE=9991231
+ F IND=1:1:LIST(0) D
+ . S DATE=$G(FIEVAL(LIST(IND),"DATE"))
+ . I DATE<MINDATE S MINDATE=DATE
+ I MINDATE=9991231 S MINDATE=0
+ Q
+ ;
+ ;============================================
+MRD(LIST,FIEVAL,MRD) ;Given a list of findings return the most recent
+ ;finding date from the list.
+ N DATE,IND
+ S MRD=0
+ F IND=1:1:LIST(0) D
+ . S DATE=$G(FIEVAL(LIST(IND),"DATE"))
+ . I DATE>MRD S MRD=DATE
+ Q
+ ;
+ ;============================================
+VALUE(LIST,FIEVAL,VALUE) ;Given a finding return one of its "CSUB"
+ ;values.
+ S VALUE=$G(FIEVAL(LIST(1),LIST(2),LIST(3)))
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m

@@ -1 @@
-PXRMFFAT        ;SLC/PKR - Function Finding argument type routines. ;09/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;============================================
-ARGTYPE(FUNCTION,AN)    ;Given a FUNCTION and argument number return the
-        ;corresponding argument type. Possible argument types are:
-        ; F - finding
-        ; N - number
-        ; S - string
-        ; U - undefined
-        N ROUTINE
-        ;The routine for any function is the same as the name of the
-        ;function except for functions with "_" in the name. In that
-        ;case the "_" is removed.
-        S ROUTINE="$$"_$TR(FUNCTION,"_","")_"(AN)"
-        Q @ROUTINE
-        ;
-        ;============================================
-COUNT(AN)       ;
-        Q $S(AN=1:"F",1:"U")
-        ;
-        ;===========================================
-DIFFDATE(AN)    ;
-        Q $S(AN=1:"F",AN=2:"F",1:"U")
-        ;
-        ;===========================================
-DUR(AN) ;
-        Q $S(AN=1:"F",1:"U")
-        ;
-        ;============================================
-FI(AN)  ;
-        Q $S(AN=1:"F",1:"U")
-        ;
-        ;============================================
-MAXDATE(AN)     ;
-        I AN>0,AN<100 Q "F"
-        E  Q "U"
-        ;
-        ;============================================
-MINDATE(AN)     ;
-        I AN>0,AN<100 Q "F"
-        E  Q "U"
-        ;
-        ;============================================
-MRD(AN) ;
-        I AN>0,AN<100 Q "F"
-        E  Q "U"
-        ;
-        ;============================================
-NUMERIC(AN)     ;
-        Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U")
-        ;
-        ;============================================
-VALUE(AN)       ;
-        Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U")
-        ;
+PXRMFFAT ;SLC/PKR - Function Finding argument type routines. ;08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;============================================
+ARGTYPE(FUNCTION,AN) ;Given a FUNCTION and argument number return the
+ ;corresponding argument type. Possible argument types are:
+ ; F - finding
+ ; N - number
+ ; S - string
+ ; U - undefined
+ N ROUTINE
+ ;The routine for any function is the same as the name of the
+ ;function except for functions with "_" in the name. In that
+ ;case the "_" is removed.
+ S ROUTINE="$$"_$TR(FUNCTION,"_","")_"(AN)"
+ Q @ROUTINE
+ ;
+ ;============================================
+COUNT(AN) ;
+ Q $S(AN=1:"F",1:"U")
+ ;
+ ;===========================================
+DIFFDATE(AN) ;
+ Q $S(AN=1:"F",AN=2:"F",1:"U")
+ ;
+ ;===========================================
+DUR(AN) ;
+ Q $S(AN=1:"F",1:"U")
+ ;
+ ;============================================
+FI(AN) ;
+ Q $S(AN=1:"F",1:"U")
+ ;
+ ;============================================
+MAXDATE(AN) ;
+ I AN>0,AN<100 Q "F"
+ E  Q "U"
+ ;
+ ;============================================
+MINDATE(AN) ;
+ I AN>0,AN<100 Q "F"
+ E  Q "U"
+ ;
+ ;============================================
+MRD(AN) ;
+ I AN>0,AN<100 Q "F"
+ E  Q "U"
+ ;
+ ;============================================
+VALUE(AN) ;
+ Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U")
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m

@@ -1 @@
-PXRMFFDB        ;SLC/PKR - Function finding data structure builder. ;10/31/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;===========================================
-BASE2(NUM)      ;Convert a base 10 integer to base 2.
-        N BD,BIN
-        S BIN=""
-        F  Q:NUM=0  D
-        . S BD=$S((NUM\2)=(NUM/2):0,1:1)
-        . S BIN=BD_BIN,NUM=NUM\2
-        Q BIN
-        ;
-        ;===========================================
-CRESLOG(NUM,FLIST,RESLOG)       ;Check the resolution logic to see if
-        ;it can be made true solely by function findings. If that is the case
-        ;warn the user. Called by BLDRESLS^PXRMLOGX
-        N AGEFI,BP,FI,FF,FFL,IND,JND,KND,LE,LEN,LND,NFF,NTC,SEXFI,TEMP,VALUE
-        S (AGEFI,SEXFI)=0
-        S NFF=0
-        F IND=1:1:NUM D
-        . S JND=$P(FLIST,";",IND)
-        . I +JND=JND S FI(JND)=0 Q
-        . I JND["FF" S NFF=NFF+1,FF=$P(JND,"FF",2),FFL(NFF)=FF
-        I NFF=0 Q
-        ;Generate and test all combinations of true and false FFs.
-        S VALUE=0
-        S NTC=$$PWR^XLFMTH(2,NFF)-1
-        F IND=1:1:NTC Q:VALUE  D
-        . S BIN=$$BASE2(IND)
-        . S LEN=$L(BIN)
-        . S LE=NFF-LEN
-        .;Fill in the values for the implied preceeding 0s.
-        . F JND=1:1:LE S KND=FFL(JND),FF(KND)=0
-        . S LND=0
-        . F JND=LE+1:1:NFF D
-        .. S KND=FFL(JND),LND=LND+1
-        .. S FF(KND)=$E(BIN,LND)
-        . I @RESLOG
-        . S VALUE=$T
-        I VALUE D
-        . N RESLSTR
-        . S RESLSTR=RESLOG
-        . F IND=1:1:NUM D
-        .. S JND=$P(FLIST,";",IND)
-        .. S TEMP=$S(JND["FF":"FF("_$P(JND,"FF",2)_")",1:"FI("_JND_")")
-        .. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,TEMP,@TEMP)
-        . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"AGE",AGEFI)
-        . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"SEX",SEXFI)
-        . W !!,"Warning - your resolution logic can be satisfied by function findings only."
-        . W !,"If this happens it will not be possible to calculate a resolution date and"
-        . W !,"the reminder will not be resolved. Here is a case where the logic evaluates"
-        . W !,"to true:"
-        . W !,RESLSTR
-        . W !,RESLOG
-        . W !
-        Q
-        ;
-        ;=============================================================
-FFBUILD(X,DA)   ;Given a function finding logical string build the data
-        ;structure. This is called by a new-style cross-reference after
-        ;the function string has passed the input transform so we don't need
-        ;to validate the elements.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        N FDA,FUNNUM,FUNP,IENB,IENS,IND,JND,L2,L3,LEN,LIST,LOGIC,OPER,MSG
-        N PFSTACK,REPL,RS,TEMP,TS,XS
-        S IENB=DA_","_DA(1)_","
-        S OPER="!&-+<>='"
-        S XS=$$PSPACE(X)
-        D POSTFIX^PXRMSTAC(XS,OPER,.PFSTACK)
-        S (FUNNUM,L2)=0
-        F IND=1:1:PFSTACK(0) D
-        . S TEMP=PFSTACK(IND)
-        . I $D(^PXRMD(802.4,"B",TEMP)) D
-        .. S FUNP=$O(^PXRMD(802.4,"B",TEMP,""))
-        .. S FUNNUM=FUNNUM+1,L2=L2+1
-        .. S IENS="+"_L2_","_IENB
-        .. S FDA(811.9255,IENS,.01)=FUNNUM
-        .. S FDA(811.9255,IENS,.02)=FUNP
-        .. S IND=IND+1
-        .. S LIST=$TR(PFSTACK(IND),"~"," ")
-        .. S REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")"
-        .. S L3=L2
-        .. S LEN=$L(LIST,",")
-        .. F JND=1:1:LEN D
-        ... S L3=L3+1
-        ... S IENS="+"_L3_",+"_L2_","_IENB
-        ... S TS=$P(LIST,",",JND)
-        ... S TS=$TR(TS,"""","")
-        ... S FDA(811.9256,IENS,.01)=TS
-        .. S L2=L3
-        ;Build the logic string
-        S LOGIC=X
-        F IND=1:1:FUNNUM D
-        . S TS=$P(REPL(IND),U,1)
-        . S RS=$P(REPL(IND),U,2)
-        . S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS)
-        S FDA(811.925,IENB,10)=LOGIC
-        D UPDATE^DIE("","FDA","IENB","MSG")
-        I $D(MSG) D
-        . W !,"The update failed, UPDATE^DIE returned the following error message:"
-        . D AWRITE^PXRMUTIL("MSG")
-        Q
-        ;
-        ;=============================================================
-FFKILL(X,DA)    ;This is the kill logic for the function string.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        K ^PXD(811.9,DA(1),25,DA,5),^PXD(811.9,DA(1),25,DA,10)
-        Q
-        ;
-        ;=============================================================
-ISGRV(VAR)      ;Return true if VAR is a global reminder variable.
-        I VAR="PXRMAGE" Q 1
-        I VAR="PXRMDOB" Q 1
-        I VAR="PXRMLAD" Q 1
-        I VAR="PXRMSEX" Q 1
-        Q 0
-        ;
-        ;=============================================================
-ISSTR(STRING)   ;Return true if STRING really is a string and it is not
-        ;executable Mumps code.
-        N VALID,X
-        S VALID=0
-        ;Valid strings are "text" or because of $P ,"text" or ",U".
-        I $E(STRING,1)="""",$E(STRING,$L(STRING))="""" S VALID=1
-        I 'VALID,$E(STRING,1)=",",$E(STRING,2)="""",$E(STRING,$L(STRING))="""" S VALID=1
-        I 'VALID,STRING=",U" S VALID=1
-        I 'VALID Q VALID
-        S X=STRING
-        D ^DIM
-        S VALID=$S($D(X)=0:1,1:0)
-        Q VALID
-        ;
-        ;=============================================================
-PSPACE(OPR)     ;OPR is an operand in a function finding, if some portion
-        ;of OPR is a string translate a space into "~" so it is preserved.
-        ;Note this will work for the entire function string.
-        N DONE,END,START,TNS,TS
-        S DONE=0,END=1
-        F  Q:DONE  D
-        . S START=$F(OPR,"""",END)
-        . I START=0 S DONE=1 Q
-        . S END=$F(OPR,"""",START)
-        . S TS=$E(OPR,START,END-2)
-        . S TNS=$TR(TS," ","~")
-        . S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
-        Q OPR
-        ;
-        ;=============================================================
-VFFORM(TEMP,X)  ;Make sure the function has a valid form, i.e., function
-        ;followed by an argument list.
-        N DONE,LP,RP,START,VALID
-        S DONE=0,VALID=1,START=0
-        F  Q:DONE  D
-        . S START=$F(X,TEMP,START)
-        . I START=0 S DONE=1 Q
-        . S LP=$E(X,START)
-        . I LP'="(" S VALID=0,DONE=1 Q
-        . S START=$F(X,")",START)
-        . S RP=$E(X,START-1)
-        . I RP'=")" S VALID=0
-        I 'VALID D
-        . N TEXT
-        . S TEXT="Function "_TEMP_" must be followed by an argument list!"
-        . D EN^DDIOL(.TEXT)
-        Q VALID
-        ;
-        ;=============================================================
-VFINDING(X,DAI) ;Make sure a finding number is a valid member of the
-        ;definition finding multiple. Input transform for function
-        ;finding finding number.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q 1
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q 1
-        I '$D(DAI) Q 1
-        ;If X is not numeric it is not a finding number.
-        I +X'=X Q 1
-        I $D(^PXD(811.9,DAI,20,X,0)) Q 1
-        E  D  Q 0
-        . N TEXT
-        . S TEXT="Finding number "_X_" does not exist!"
-        . D EN^DDIOL(TEXT)
-        ;
-        ;=============================================================
-VFSTRING(FFSTRING,DA)   ;Make sure a function finding string is valid.
-        ;The elements can be functions, operators, and numbers.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q 1
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q 1
-        I '$D(DA) Q 1
-        N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID
-        S DAI=DA(1)
-        S OPER="!&-+<>='"
-        ;Define the allowed M functions.
-        S MFUN("$P")=""
-        D POSTFIX^PXRMSTAC(FFSTRING,OPER,.PFSTACK)
-        S VALID=1
-        F IND=1:1:PFSTACK(0) Q:'VALID  D
-        . S TEMP=PFSTACK(IND)
-        . I $D(^PXRMD(802.4,"B",TEMP)) D  Q
-        .. S VALID=$$VFFORM(TEMP,X)
-        .. I 'VALID Q
-        .. S FUNIEN=$O(^PXRMD(802.4,"B",TEMP,""))
-        .. S IND=IND+1
-        .. S LIST=$G(PFSTACK(IND))
-        .. S VALID=$$VLIST(LIST,DAI,TEMP,FUNIEN)
-        .;Check for operator
-        . I OPER[TEMP Q
-        .;Check for number
-        . I TEMP=+TEMP Q
-        .;Check for allowed M function.
-        . I $D(MFUN(TEMP)) Q
-        .;Check for a global reminder variable
-        . I $$ISGRV(TEMP) Q
-        .;Check for a non-executable string.
-        . I $$ISSTR(TEMP) Q
-        . S VALID=0
-        . S TEXT=TEMP_" is not a valid Function Finding element!"
-        . D EN^DDIOL(TEXT)
-        I VALID D
-        . N X
-        . S X="I "_FFSTRING
-        . D ^DIM
-        . I $D(X)=0 S VALID=0
-        I 'VALID D
-        . S TEMP=FFSTRING_" is not a valid function string"
-        . D EN^DDIOL(TEMP)
-        Q VALID
-        ;
-        ;=============================================================
-VLIST(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
-        ;is valid.
-        N AT,IND,LEN,PATTERN,VALID,X
-        S LEN=$L(LIST,",")
-        I LEN=0 D  Q 0
-        . N TEXT
-        . S TEXT="The argument list is not defined!"
-        . D EN^DDIOL(TEXT)
-        S PATTERN=$P(^PXRMD(802.4,FUNIEN,0),U,5)
-        S VALID=$S(LIST?@PATTERN:1,1:0)
-        I 'VALID D  Q 0
-        . N TEXT
-        . S TEXT="Argument list "_LIST_" is not correct for function "_$P(^PXRMD(802.4,FUNIEN,0),U,1)
-        . D EN^DDIOL(TEXT)
-        F IND=1:1:LEN D
-        . S X=$P(LIST,",",IND)
-        . S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
-        . I AT="U" S VALID=0 Q
-        . I AT="F",'$$VFINDING(X,DAI) S VALID=0
-        Q VALID
-        ;
+PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;06/22/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;===========================================
+BASE2(NUM) ;Convert a base 10 integer to base 2.
+ N BD,BIN
+ S BIN=""
+ F  Q:NUM=0  D
+ . S BD=$S((NUM\2)=(NUM/2):0,1:1)
+ . S BIN=BD_BIN,NUM=NUM\2
+ Q BIN
+ ;
+ ;===========================================
+CRESLOG(NUM,FLIST,RESLOG) ;Check the resolution logic to see if
+ ;it can be made true solely by function findings. If that is the case
+ ;warn the user. Called by BLDRESLS^PXRMLOGX
+ N AGEFI,BP,FI,FF,FFL,IND,JND,KND,LE,LEN,LND,NFF,NTC,SEXFI,TEMP,VALUE
+ S (AGEFI,SEXFI)=0
+ S NFF=0
+ F IND=1:1:NUM D
+ . S JND=$P(FLIST,";",IND)
+ . I +JND=JND S FI(JND)=0 Q
+ . I JND["FF" S NFF=NFF+1,FF=$P(JND,"FF",2),FFL(NFF)=FF
+ I NFF=0 Q
+ ;Generate and test all combinations of true and false FFs.
+ S VALUE=0
+ S NTC=$$PWR^XLFMTH(2,NFF)-1
+ F IND=1:1:NTC Q:VALUE  D
+ . S BIN=$$BASE2(IND)
+ . S LEN=$L(BIN)
+ . S LE=NFF-LEN
+ .;Fill in the values for the implied preceeding 0s.
+ . F JND=1:1:LE S KND=FFL(JND),FF(KND)=0
+ . S LND=0
+ . F JND=LE+1:1:NFF D
+ .. S KND=FFL(JND),LND=LND+1
+ .. S FF(KND)=$E(BIN,LND)
+ . I @RESLOG
+ . S VALUE=$T
+ I VALUE D
+ . N RESLSTR
+ . S RESLSTR=RESLOG
+ . F IND=1:1:NUM D
+ .. S JND=$P(FLIST,";",IND)
+ .. S TEMP=$S(JND["FF":"FF("_$P(JND,"FF",2)_")",1:"FI("_JND_")")
+ .. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,TEMP,@TEMP)
+ . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"AGE",AGEFI)
+ . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"SEX",SEXFI)
+ . W !!,"Warning - your resolution logic can be satisfied by function findings only."
+ . W !,"If this happens it will not be possible to calculate a resolution date and"
+ . W !,"the reminder will not be resolved. Here is a case where the logic evaluates"
+ . W !,"to true:"
+ . W !,RESLSTR
+ . W !,RESLOG
+ . W !
+ Q
+ ;
+ ;=============================================================
+FFBUILD(X,DA) ;Given a function finding logical string build the data
+ ;structure. This is called by a new-style cross-reference after
+ ;the function string has passed the input transform so we don't need
+ ;to validate the elements.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ N FDA,FUNNUM,FUNP,IENB,IENS,IND,JND,L2,L3,LEN,LIST,LOGIC,OPER,MSG
+ N PFSTACK,REPL,RS,TEMP,TS,XS
+ S IENB=DA_","_DA(1)_","
+ S OPER="!&<>='"
+ S XS=$$PSPACE(X)
+ D POSTFIX^PXRMSTAC(XS,OPER,.PFSTACK)
+ S (FUNNUM,L2)=0
+ F IND=1:1:PFSTACK(0) D
+ . S TEMP=PFSTACK(IND)
+ . I $D(^PXRMD(802.4,"B",TEMP)) D
+ .. S FUNP=$O(^PXRMD(802.4,"B",TEMP,""))
+ .. S FUNNUM=FUNNUM+1,L2=L2+1
+ .. S IENS="+"_L2_","_IENB
+ .. S FDA(811.9255,IENS,.01)=FUNNUM
+ .. S FDA(811.9255,IENS,.02)=FUNP
+ .. S IND=IND+1
+ .. S LIST=$TR(PFSTACK(IND),"~"," ")
+ .. S REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")"
+ .. S L3=L2
+ .. S LEN=$L(LIST,",")
+ .. F JND=1:1:LEN D
+ ... S L3=L3+1
+ ... S IENS="+"_L3_",+"_L2_","_IENB
+ ... S TS=$P(LIST,",",JND)
+ ... S TS=$TR(TS,"""","")
+ ... S FDA(811.9256,IENS,.01)=TS
+ .. S L2=L3
+ ;Build the logic string
+ S LOGIC=X
+ F IND=1:1:FUNNUM D
+ . S TS=$P(REPL(IND),U,1)
+ . S RS=$P(REPL(IND),U,2)
+ . S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS)
+ S FDA(811.925,IENB,10)=LOGIC
+ D UPDATE^DIE("","FDA","IENB","MSG")
+ I $D(MSG) D
+ . W !,"The update failed, UPDATE^DIE returned the following error message:"
+ . D AWRITE^PXRMUTIL("MSG")
+ Q
+ ;
+ ;=============================================================
+FFKILL(X,DA) ;This is the kill logic for the function string.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ K ^PXD(811.9,DA(1),25,DA,5),^PXD(811.9,DA(1),25,DA,10)
+ Q
+ ;
+ ;=============================================================
+ISGRV(VAR) ;Return true if VAR is a global reminder variable.
+ I VAR="PXRMAGE" Q 1
+ I VAR="PXRMDOB" Q 1
+ I VAR="PXRMLAD" Q 1
+ I VAR="PXRMSEX" Q 1
+ Q 0
+ ;
+ ;=============================================================
+ISSTR(STRING) ;Return true if STRING really is a string and it is not
+ ;executable Mumps code.
+ N VALID,X
+ S VALID=0
+ ;Valid strings are "text" or because of $P ,"text" or ",U".
+ I $E(STRING,1)="""",$E(STRING,$L(STRING))="""" S VALID=1
+ I 'VALID,$E(STRING,1)=",",$E(STRING,2)="""",$E(STRING,$L(STRING))="""" S VALID=1
+ I 'VALID,STRING=",U" S VALID=1
+ I 'VALID Q VALID
+ S X=STRING
+ D ^DIM
+ S VALID=$S($D(X)=0:1,1:0)
+ Q VALID
+ ;
+ ;=============================================================
+PSPACE(OPR) ;OPR is an operand in a function finding, if some portion
+ ;of OPR is a string translate a space into "~" so it is preserved.
+ N END,START,TNS,TS
+ S START=$F(OPR,"""")
+ I START=0 Q OPR
+ S END=$F(OPR,"""",START)-2
+ S TS=$E(OPR,START,END)
+ S TNS=$TR(TS," ","~")
+ S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
+ Q OPR
+ ;
+ ;=============================================================
+VFFORM(TEMP,X) ;Make sure the function has a valid form, i.e., function
+ ;followed by an argument list.
+ N DONE,LP,RP,START,VALID
+ S DONE=0,VALID=1,START=0
+ F  Q:DONE  D
+ . S START=$F(X,TEMP,START)
+ . I START=0 S DONE=1 Q
+ . S LP=$E(X,START)
+ . I LP'="(" S VALID=0,DONE=1 Q
+ . S START=$F(X,")",START)
+ . S RP=$E(X,START-1)
+ . I RP'=")" S VALID=0
+ I 'VALID D
+ . N TEXT
+ . S TEXT="Function "_TEMP_" must be followed by an argument list!"
+ . D EN^DDIOL(.TEXT)
+ Q VALID
+ ;
+ ;=============================================================
+VFINDING(X,DAI) ;Make sure a finding number is a valid member of the
+ ;definition finding multiple. Input transform for function
+ ;finding finding number.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q 1
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q 1
+ I '$D(DAI) Q 1
+ ;If X is not numeric it is not a finding number.
+ I +X'=X Q 1
+ I $D(^PXD(811.9,DAI,20,X,0)) Q 1
+ E  D  Q 0
+ . N TEXT
+ . S TEXT="Finding number "_X_" does not exist!"
+ . D EN^DDIOL(TEXT)
+ ;
+ ;=============================================================
+VFSTRING(FFSTRING,DA) ;Make sure a function finding string is valid.
+ ;The elements can be functions, operators, and numbers.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q 1
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q 1
+ I '$D(DA) Q 1
+ N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID
+ S DAI=DA(1)
+ S OPER="!&<>='"
+ ;Define the allowed M functions.
+ S MFUN("$P")=""
+ D POSTFIX^PXRMSTAC(FFSTRING,OPER,.PFSTACK)
+ S VALID=1
+ F IND=1:1:PFSTACK(0) Q:'VALID  D
+ . S TEMP=PFSTACK(IND)
+ . I $D(^PXRMD(802.4,"B",TEMP)) D  Q
+ .. S VALID=$$VFFORM(TEMP,X)
+ .. I 'VALID Q
+ .. S FUNIEN=$O(^PXRMD(802.4,"B",TEMP,""))
+ .. S IND=IND+1
+ .. S LIST=$G(PFSTACK(IND))
+ .. S VALID=$$VLIST(LIST,DAI,TEMP,FUNIEN)
+ .;Check for operator
+ . I OPER[TEMP Q
+ .;Check for number
+ . I TEMP=+TEMP Q
+ .;Check for allowed M function.
+ . I $D(MFUN(TEMP)) Q
+ .;Check for a global reminder variable
+ . I $$ISGRV(TEMP) Q
+ .;Check for a non-executable string.
+ . I $$ISSTR(TEMP) Q
+ . S VALID=0
+ . S TEXT=TEMP_" is not a valid Function Finding element!"
+ . D EN^DDIOL(TEXT)
+ I VALID D
+ . N X
+ . S X="I "_FFSTRING
+ . D ^DIM
+ . I $D(X)=0 S VALID=0
+ I 'VALID D
+ . S TEMP=FFSTRING_" is not a valid function string"
+ . D EN^DDIOL(TEMP)
+ Q VALID
+ ;
+ ;=============================================================
+VLIST(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
+ ;is valid.
+ N AT,IND,LEN,PATTERN,VALID,X
+ S LEN=$L(LIST,",")
+ I LEN=0 D  Q 0
+ . N TEXT
+ . S TEXT="The argument list is not defined!"
+ . D EN^DDIOL(TEXT)
+ S PATTERN=$P(^PXRMD(802.4,FUNIEN,0),U,5)
+ S VALID=$S(LIST?@PATTERN:1,1:0)
+ I 'VALID D  Q 0
+ . N TEXT
+ . S TEXT="Argument list "_LIST_" is not correct for function "_$P(^PXRMD(802.4,FUNIEN,0),U,1)
+ . D EN^DDIOL(TEXT)
+ F IND=1:1:LEN D
+ . S X=$P(LIST,",",IND)
+ . S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
+ . I AT="U" S VALID=0 Q
+ . I AT="F",'$$VFINDING(X,DAI) S VALID=0
+ Q VALID
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m

@@ -1 @@
-PXRMGECN        ;SLC/JVS GEC-Score Reports-cont'd ;06/01/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        Q
-SUM     ;By Summary by Patient
-        N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA
-        N DATER,SDATE,SCNT
-        D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY)
-        I FORMAT="D" S FOR=0
-        I FORMAT="F" S FOR=1
-        W @IOF
-        S CATDANA("GEC REFERRAL BASIC ADL")=""
-        S CATDANA("GEC REFERRAL IADL")=""
-        S CATDANA("GEC REFERRAL SKILLED CARE")=""
-        S CATDANA("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")=""
-        ;
-        S Y=1,SUM=0,DATER=0,GSUM=0
-        S DFN="" F  S DFN=$O(^TMP("PXRMGEC",$J,"HS1",DFN)) Q:DFN=""!(Y=0)  D
-        .S CNTREF="",REFNUM=0 F  S CNTREF=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF)) Q:CNTREF=""!(Y=0)  D
-        ..S REFNUM=REFNUM+1
-        ..S SDATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,0)) D
-        ...S DATER=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,SDATE,0))
-        ..S DATE=0 F  S DATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE)) Q:DATE=""!(Y=0)  D
-        ...S VDT=0 F  S VDT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT)) Q:VDT=""!(Y=0)  D
-        ....S CAT=0 F  S CAT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT)) Q:CAT=""!(Y=0)  D
-        .....Q:'$D(CATDANA(CAT))
-        .....S SUM=0
-        .....S DATEV=0 F  S DATEV=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV)) Q:DATEV=""!(Y=0)  D
-        ......S DA=0 F  S DA=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV,DA)) Q:DA=""!(Y=0)  D
-        .......S HFN=$$HFNAME^PXRMGECR(DA)
-        .......S SUM=SUM+$$VALUE($P($G(^AUPNVHF(DA,0)),"^",1))
-        .......S CATSUM(CAT)=SUM
-        ..S GSUM=+$G(CATSUM("GEC REFERRAL IADL"))+(+$G(CATSUM("GEC REFERRAL BASIC ADL")))+(+$G(CATSUM("GEC REFERRAL SKILLED CARE")))+(+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")))
-        ..S ^TMP("PXRMGEC",$J,"S",DFN,SDATE,DATER,+$G(CATSUM("GEC REFERRAL IADL")),+$G(CATSUM("GEC REFERRAL BASIC ADL")),+$G(CATSUM("GEC REFERRAL SKILLED CARE")),+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")),GSUM)=""
-        ..K CATSUM
-        ;
-DIS     ;Start of Display
-        S REF="^TMP(""PXRMGEC"",$J,""S"")"
-        W !,"=============================================================================="
-        W !,"GEC Patient-Summary (Score)"
-        W !,"Data on Complete Referrals Only"
-        W !,"From: "_$$FMTE^XLFDT(BDT,"5ZM")_" To: "_$$FMTE^XLFDT(EDT,"5ZM")
-        W !
-        I FOR W !,?33,"Finished",?49,"Basic",?55,"Skilled",?63,"Patient",?73,"TOTAL"
-        I FOR W !,"Name",?22,"SSN",?33,"Date",?44,"IADL",?49,"ADL",?55,"Care",?63,"Behaviors",?73,"ACROSS"
-        I 'FOR W !,"Name^SSN^Referral Date^IADL^Basic ADL^Skilled Care^Behaviors^Totals"
-        W !,"=============================================================================="
-        N S1,S2,S3,S4,S5,S1T,S2T,S3T,S4T,S5T
-        S (S1T,S2T,S3T,S4T,S5T,CNT)=0
-        S DFN="" F  S DFN=$O(@REF@(DFN)) Q:DFN=""  D
-        .S SDATE="" F  S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE=""  D
-        ..S DATER="" F  S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER=""  D
-        ...S CNT=CNT+1
-        ...S S1="" F  S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1=""  D
-        ....S S1T=S1T+S1
-        ....S S2="" F  S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2=""  D
-        .....S S2T=S2T+S2
-        .....S S3="" F  S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3=""  D
-        ......S S3T=S3T+S3
-        ......S S4="" F  S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4=""  D
-        .......S S4T=S4T+S4
-        .......S S5="" F  S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5=""  D
-        ........S S5T=S5T+S5
-        ........I FOR W !,$E($P(DFN," ",1,$L(DFN," ")-1),1,19),?20," ("_$P(DFN," ",$L(DFN," "))_")",?33,$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),?44,$J(S1,3),?49,$J(S2,3),?55,$J(S3,3),?63,$J(S4,3),?73,$J(S5,3)
-        ........D PB Q:Y=0
-        ........I 'FOR W !,$P(DFN," ",1,$L(DFN," ")-1),"^",$P(DFN," ",$L(DFN," ")),"^",$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),"^",S1,"^",S2,"^",S3,"^",S4,"^",S5
-        Q:CNT=0
-        I FOR W !,?44,"_________________________________" D PB Q:Y=0
-        I FOR W !,?33,"Totals > >",?44,$J(S1T,3),?49,$J(S2T,3),?55,$J(S3T,3),?63,$J(S4T,3),?72,$J(S5T,4) D PB Q:Y=0
-        I FOR W !,?34,"Means > >",?44,$J($FN(S1T/CNT,"",1),3),?49,$J($FN(S2T/CNT,"",1),3),?55,$J($FN(S3T/CNT,"",1),3),?63,$J($FN(S4T/CNT,"",1),3),?72,$J($FN(S5T/CNT,"",1),4)
-        D PB Q:Y=0
-        S (S1T,S2T,S3T,S4T,S5T,SCNT)=0
-        N S1TDEV,S1TDEVT,S2TDEV,S2TDEVT,S3TDEV,S3TDEVT,S4TDEV,S4TDEVT,S5TDEV,S5TDEVT
-        S (S1TDEVT,S2TDEVT,S3TDEVT,S4TDEVT,S5TDEVT)=0
-        S DFN="" F  S DFN=$O(@REF@(DFN)) Q:DFN=""  D
-        .S SDATE="" F  S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE=""  D
-        ..S DATER="" F  S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER=""  D
-        ...S S1="" F  S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1=""  D
-        ....S S1TDEV=(S1-(S1T/CNT))*(S1-(S1T/CNT)) S S1TDEVT=S1TDEVT+S1TDEV
-        ....S S2="" F  S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2=""  D
-        .....S S2TDEV=(S2-(S2T/CNT))*(S2-(S2T/CNT)) S S2TDEVT=S2TDEVT+S2TDEV
-        .....S S3="" F  S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3=""  D
-        ......S S3TDEV=(S3-(S3T/CNT))*(S3-(S3T/CNT)) S S3TDEVT=S3TDEVT+S3TDEV
-        ......S S4="" F  S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4=""  D
-        .......S S4TDEV=(S4-(S4T/CNT))*(S4-(S4T/CNT)) S S4TDEVT=S4TDEVT+S4TDEV
-        .......S S5="" F  S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5=""  D
-        ........S S5TDEV=(S5-(S5T/CNT))*(S5-(S5T/CNT)) S S5TDEVT=S5TDEVT+S5TDEV
-        I FOR W !,?20,"Standard Deviations > >"
-        I CNT<2 S CNT=CNT+1
-        I FOR W ?44,$J($FN($$SQROOT(S1TDEVT/(CNT-1)),"",1),3),?49,$J($FN($$SQROOT(S2TDEVT/(CNT-1)),"",1),3),?55,$J($FN($$SQROOT(S3TDEVT/(CNT-1)),"",1),3),?63,$J($FN($$SQROOT(S4TDEVT/(CNT-1)),"",1),3),?72,$J($FN($$SQROOT(S5TDEVT/(CNT-1)),"",1),4)
-        D PB Q:Y=0
-        W ! D PB Q:Y=0
-        K ^TMP("PXRMGEC",$J)
-        D KILL^%ZISS
-        Q
-        ;
-SQROOT(NUM)     ;Calculat Square Root
-        N PREC,ROOT S ROOT=0 GOTO SQROOTX:NUM=0
-        S:NUM<0 NUM=-NUM S ROOT=$S(NUM>1:NUM\1,1:1/NUM)
-        S ROOT=$E(ROOT,1,$L(ROOT)+1\2) S:NUM'>1 ROOT=1/ROOT
-        F PREC=1:1:6 S ROOT=NUM/ROOT+ROOT*.5
-SQROOTX Q ROOT
-        ;
-VALUE(DA)       ;Return value for score
-        N CAT,SYN,VALUE,PICE
-        S SYN=$P($G(^AUTTHF(DA,0)),"^",9)
-        Q:$E(SYN,5,5)'="F" VALUE
-        Q:SYN="" VALUE
-        Q:$E(SYN,5,5)="C" VALUE
-        S VALUE=$P(SYN," ",$L(SYN," "))
-        Q VALUE
-        ;
-        ;
-PB      ;PAGE BREAK
-        S Y=""
-        I $Y=(IOSL-2) D
-        .K DIR
-        .S DIR(0)="E"
-        .D ^DIR
-        .I Y=1 W @IOF S $Y=0
-        K DIR
-        Q
-        ;
+PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;6/19/03  20:58
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ Q
+SUM ;By Summary by Patient
+ N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA
+ N DATER,SDATE
+ D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY)
+ I FORMAT="D" S FOR=0
+ I FORMAT="F" S FOR=1
+ W @IOF
+ S CATDANA("GEC REFERRAL BASIC ADL")=""
+ S CATDANA("GEC REFERRAL IADL")=""
+ S CATDANA("GEC REFERRAL SKILLED CARE")=""
+ S CATDANA("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")=""
+ ;
+ S Y=1,SUM=0,DATER=0,GSUM=0
+ S DFN="" F  S DFN=$O(^TMP("PXRMGEC",$J,"HS1",DFN)) Q:DFN=""!(Y=0)  D
+ .S CNTREF="",REFNUM=0 F  S CNTREF=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF)) Q:CNTREF=""!(Y=0)  D
+ ..S REFNUM=REFNUM+1
+ ..S SDATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,0)) D
+ ...S DATER=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,SDATE,0))
+ ..S DATE=0 F  S DATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE)) Q:DATE=""!(Y=0)  D
+ ...S VDT=0 F  S VDT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT)) Q:VDT=""!(Y=0)  D
+ ....S CAT=0 F  S CAT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT)) Q:CAT=""!(Y=0)  D
+ .....Q:'$D(CATDANA(CAT))
+ .....S SUM=0
+ .....S DATEV=0 F  S DATEV=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV)) Q:DATEV=""!(Y=0)  D
+ ......S DA=0 F  S DA=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV,DA)) Q:DA=""!(Y=0)  D
+ .......S HFN=$$HFNAME^PXRMGECR(DA)
+ .......S SUM=SUM+$$VALUE($P($G(^AUPNVHF(DA,0)),"^",1))
+ .......S CATSUM(CAT)=SUM
+ ..S GSUM=+$G(CATSUM("GEC REFERRAL IADL"))+(+$G(CATSUM("GEC REFERRAL BASIC ADL")))+(+$G(CATSUM("GEC REFERRAL SKILLED CARE")))+(+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")))
+ ..S ^TMP("PXRMGEC",$J,"S",DFN,SDATE,DATER,+$G(CATSUM("GEC REFERRAL IADL")),+$G(CATSUM("GEC REFERRAL BASIC ADL")),+$G(CATSUM("GEC REFERRAL SKILLED CARE")),+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")),GSUM)=""
+ ..K CATSUM
+ ;
+DIS ;Start of Display
+ S REF="^TMP(""PXRMGEC"",$J,""S"")"
+ W !,"=============================================================================="
+ W !,"GEC Patient-Summary (Score)"
+ W !,"Data on Complete Referrals Only"
+ W !,"From: "_$$FMTE^XLFDT(BDT,"5ZM")_" To: "_$$FMTE^XLFDT(EDT,"5ZM")
+ W !
+ I FOR W !,?33,"Finished",?49,"Basic",?55,"Skilled",?63,"Patient",?73,"TOTAL"
+ I FOR W !,"Name",?22,"SSN",?33,"Date",?44,"IADL",?49,"ADL",?55,"Care",?63,"Behaviors",?73,"ACROSS"
+ I 'FOR W !,"Name^SSN^Referral Date^IADL^Basic ADL^Skilled Care^Behaviors^Totals"
+ W !,"=============================================================================="
+ N S1,S2,S3,S4,S5,S1T,S2T,S3T,S4T,S5T
+ S (S1T,S2T,S3T,S4T,S5T,CNT)=0
+ S DFN="" F  S DFN=$O(@REF@(DFN)) Q:DFN=""  D
+ .S SDATE="" F  S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE=""  D
+ ..S DATER="" F  S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER=""  D
+ ...S CNT=CNT+1
+ ...S S1="" F  S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1=""  D
+ ....S S1T=S1T+S1
+ ....S S2="" F  S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2=""  D
+ .....S S2T=S2T+S2
+ .....S S3="" F  S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3=""  D
+ ......S S3T=S3T+S3
+ ......S S4="" F  S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4=""  D
+ .......S S4T=S4T+S4
+ .......S S5="" F  S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5=""  D
+ ........S S5T=S5T+S5
+ ........I FOR W !,$E($P(DFN," ",1,$L(DFN," ")-1),1,19),?20," ("_$P(DFN," ",$L(DFN," "))_")",?33,$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),?44,$J(S1,3),?49,$J(S2,3),?55,$J(S3,3),?63,$J(S4,3),?73,$J(S5,3)
+ ........D PB Q:Y=0
+ ........I 'FOR W !,$P(DFN," ",1,$L(DFN," ")-1),"^",$P(DFN," ",$L(DFN," ")),"^",$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),"^",S1,"^",S2,"^",S3,"^",S4,"^",S5
+ Q:CNT=0
+ I FOR W !,?44,"_________________________________" D PB Q:Y=0
+ I FOR W !,?33,"Totals > >",?44,$J(S1T,3),?49,$J(S2T,3),?55,$J(S3T,3),?63,$J(S4T,3),?72,$J(S5T,4) D PB Q:Y=0
+ I FOR W !,?34,"Means > >",?44,$J($FN(S1T/CNT,"",1),3),?49,$J($FN(S2T/CNT,"",1),3),?55,$J($FN(S3T/CNT,"",1),3),?63,$J($FN(S4T/CNT,"",1),3),?72,$J($FN(S5T/CNT,"",1),4)
+ D PB Q:Y=0
+ S (S1T,S2T,S3T,S4T,S5T,SCNT)=0
+ N S1TDEV,S1TDEVT,S2TDEV,S2TDEVT,S3TDEV,S3TDEVT,S4TDEV,S4TDEVT,S5TDEV,S5TDEVT
+ S (S1TDEVT,S2TDEVT,S3TDEVT,S4TDEVT,S5TDEVT)=0
+ S DFN="" F  S DFN=$O(@REF@(DFN)) Q:DFN=""  D
+ .S SDATE="" F  S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE=""  D
+ ..S DATER="" F  S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER=""  D
+ ...S S1="" F  S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1=""  D
+ ....S S1TDEV=(S1-(S1T/CNT))*(S1-(S1T/CNT)) S S1TDEVT=S1TDEVT+S1TDEV
+ ....S S2="" F  S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2=""  D
+ .....S S2TDEV=(S2-(S2T/CNT))*(S2-(S2T/CNT)) S S2TDEVT=S2TDEVT+S2TDEV
+ .....S S3="" F  S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3=""  D
+ ......S S3TDEV=(S3-(S3T/CNT))*(S3-(S3T/CNT)) S S3TDEVT=S3TDEVT+S3TDEV
+ ......S S4="" F  S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4=""  D
+ .......S S4TDEV=(S4-(S4T/CNT))*(S4-(S4T/CNT)) S S4TDEVT=S4TDEVT+S4TDEV
+ .......S S5="" F  S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5=""  D
+ ........S S5TDEV=(S5-(S5T/CNT))*(S5-(S5T/CNT)) S S5TDEVT=S5TDEVT+S5TDEV
+ I FOR W !,?20,"Standard Deviations > >"
+ I CNT<2 S CNT=CNT+1
+ I FOR W ?44,$J($FN($$SQROOT(S1TDEVT/(CNT-1)),"",1),3),?49,$J($FN($$SQROOT(S2TDEVT/(CNT-1)),"",1),3),?55,$J($FN($$SQROOT(S3TDEVT/(CNT-1)),"",1),3),?63,$J($FN($$SQROOT(S4TDEVT/(CNT-1)),"",1),3),?72,$J($FN($$SQROOT(S5TDEVT/(CNT-1)),"",1),4)
+ D PB Q:Y=0
+ W ! D PB Q:Y=0
+ K ^TMP("PXRMGEC",$J)
+ D KILL^%ZISS
+ Q
+ ;
+SQROOT(NUM) ;Calculat Square Root
+ N PREC,ROOT S ROOT=0 GOTO SQROOTX:NUM=0
+ S:NUM<0 NUM=-NUM S ROOT=$S(NUM>1:NUM\1,1:1/NUM)
+ S ROOT=$E(ROOT,1,$L(ROOT)+1\2) S:NUM'>1 ROOT=1/ROOT
+ F PREC=1:1:6 S ROOT=NUM/ROOT+ROOT*.5
+SQROOTX Q ROOT
+ ;
+VALUE(DA) ;Return value for score
+ N CAT,SYN,VALUE,PICE
+ S SYN=$P($G(^AUTTHF(DA,0)),"^",9)
+ Q:$E(SYN,5,5)'="F" VALUE
+ Q:SYN="" VALUE
+ Q:$E(SYN,5,5)="C" VALUE
+ S VALUE=$P(SYN," ",$L(SYN," "))
+ Q VALUE
+ ;
+ ;
+PB ;PAGE BREAK
+ S Y=""
+ I $Y=(IOSL-2) D
+ .K DIR
+ .S DIR(0)="E"
+ .D ^DIR
+ .I Y=1 W @IOF S $Y=0
+ K DIR
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m

@@ -1 @@
-PXRMHF  ; SLC/PKR - Handle Health Factor findings. ;06/01/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;=====================================================
-CATSORT(FIEVAL,FIND0,FARR)      ;Sort all the true health factor findings
-        ;according to the category criteria. FIND0 will be defined only
-        ;for terms.
-        N CAT,CATLIST,DATE,IND,FI,HFIEN,LDATE,NTRUE,WCR
-        S HFIEN=""
-        F  S HFIEN=$O(FARR("E","AUTTHF(",HFIEN)) Q:HFIEN=""  D
-        . S FI=0
-        . F  S FI=$O(FARR("E","AUTTHF(",HFIEN,FI)) Q:FI=""  D
-        .. I 'FIEVAL(FI) Q
-        ..;Get the Within Category Rank
-        .. S WCR=$P(FARR(20,FI,0),U,10)
-        .. I WCR="" S WCR=$P(FIND0,U,10)
-        .. I WCR="" S WCR=9999
-        ..;If Within Category Rank is 0 ignore the category and treat it like
-        ..;regular finding (exclude it from the list).
-        .. I WCR>0 D
-        ... S CAT=$P(^AUTTHF(HFIEN,0),U,3)
-        ...;If the category is null then send a warning.
-        ... I CAT="" D WARN(^AUTTHF(HFIEN,0))  Q
-        ... S CATLIST(CAT,FIEVAL(FI,"DATE"),WCR,FI)=""
-        ... I $G(PXRMDEBG) S FIEVAL(FI,"CAT^WCR")=CAT_U_WCR
-        ;No health factors to categorize then quit.
-        I '$D(CATLIST) Q
-        ;Only the most recent HF in a category can be true.
-        S CAT=""
-        F  S CAT=$O(CATLIST(CAT)) Q:CAT=""  D
-        . S LDATE=$O(CATLIST(CAT,""),-1)
-        .;For each category set all but the most recent HF false.
-        . S DATE=""
-        . F  S DATE=$O(CATLIST(CAT,DATE)) Q:DATE=LDATE  D
-        .. S WCR=""
-        .. F  S WCR=$O(CATLIST(CAT,DATE,WCR)) Q:WCR=""  D
-        ... S FI=""
-        ... F  S FI=$O(CATLIST(CAT,DATE,WCR,FI)) Q:FI=""  D
-        .... S FIEVAL(FI)=0
-        ....;If there are multiple occurrences set them all false.
-        .... S IND=0
-        .... F  S IND=+$O(FIEVAL(FI,IND)) Q:IND=0  S FIEVAL(FI,IND)=0
-        .;
-        .;If there is more than on HF on the most recent date then only the
-        .;one with the highest WCR can be true. The highest possible WCR is 1.
-        .;Set all with lower WCRs false.
-        .;If the most recent health factor has multiple occurrences only
-        .;the first occurrence can be true.
-        . S (NTRUE,WCR)=0
-        . F  S WCR=$O(CATLIST(CAT,LDATE,WCR)) Q:WCR=""  D
-        .. S FI=""
-        .. F  S FI=$O(CATLIST(CAT,LDATE,WCR,FI)) Q:FI=""  D
-        ... I NTRUE=0 D  Q
-        ....;If there are multiple sub-occurrences set them all false.
-        .... S (IND,NTRUE)=1
-        .... F  S IND=+$O(FIEVAL(FI,IND)) Q:IND=0  S FIEVAL(FI,IND)=0
-        ... S FIEVAL(FI)=0
-        ...;If there are multiple sub-occurrences set them all false.
-        ... S IND=0
-        ... F  S IND=+$O(FIEVAL(FI,IND)) Q:IND=0  S FIEVAL(FI,IND)=0
-        Q
-        ;
-        ;=====================================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate health factor findings.
-        N FIEVT,FILENUM,FINDPA,FINDING,HFIEN,NOINDEX
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
-        . S NOINDEX=1
-        E  S NOINDEX=0
-        S HFIEN=""
-        F  S HFIEN=$O(DEFARR("E",ENODE,HFIEN)) Q:+HFIEN=0  D
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,HFIEN,FINDING)) Q:+FINDING=0  D
-        .. I NOINDEX S FIEVAL(FINDING)=0 Q
-        .. K FINDPA
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. K FIEVT
-        .. D FIEVAL^PXRMINDX(FILENUM,"PI",DFN,HFIEN,.FINDPA,.FIEVT)
-        .. M FIEVAL(FINDING)=FIEVT
-        .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
-        ;Sort all the true true findings by category.
-        D CATSORT(.FIEVAL,"",.DEFARR)
-        Q
-        ;
-        ;=====================================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;Evaluate health factor term findings
-        ;for patient lists.
-        D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
-        Q
-        ;
-        ;=====================================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;Evaluate health factor terms.
-        N BDT,EDT,FIEVT,HFIEN,NOINDEX,PFINDPA
-        N TFINDPA,TFINDING
-        I $G(^PXRMINDX(9000010.23,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),9000010.23)
-        . S NOINDEX=1
-        E  S NOINDEX=0
-        S HFIEN=""
-        F  S HFIEN=$O(TERMARR("E",ENODE,HFIEN)) Q:+HFIEN=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,HFIEN,TFINDING)) Q:+TFINDING=0  D
-        .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
-        .. K FIEVT,PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D FIEVAL^PXRMINDX(9000010.23,"PI",DFN,HFIEN,.PFINDPA,.FIEVT)
-        .. M TFIEVAL(TFINDING)=FIEVT
-        .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
-        ;Sort all the true true findings by category.
-        D CATSORT(.TFIEVAL,FINDPA(0),.TERMARR)
-        Q
-        ;
-        ;=====================================================
-GETDATA(DAS,FIEVT)      ;Return data for a specified V Health Factor entry.
-        ;DBIA #4250
-        D VHF^PXPXRM(DAS,.FIEVT)
-        Q
-        ;
-        ;=====================================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        N EM,FIEN,IND,JND,LVL,NAME,NOUT,PNAME,TEMP,TEXTOUT,VDATE
-        S FIEN=$P(IFIEVAL("FINDING"),";",1)
-        S PNAME=$P(^AUTTHF(FIEN,0),U,1)
-        S NAME="Health Factor: "_PNAME_" = "
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S LVL=$G(IFIEVAL(IND,"VALUE"))
-        . I LVL'="" S LVL=$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
-        . S VDATE=IFIEVAL(IND,"DATE")
-        . S TEMP=NAME_LVL_" ("_$$EDATE^PXRMDATE(VDATE)_")"
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;=====================================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        N EM,FIEN,IND,JND,LVL,NOUT,PNAME,TEMP,TEXTOUT,VDATE
-        S FIEN=$P(IFIEVAL("FINDING"),";",1)
-        ;DBIA #3083
-        S PNAME=$P(^AUTTHF(FIEN,0),U,1)
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Health Factor: "_PNAME
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S VDATE=IFIEVAL(IND,"DATE")
-        . S TEMP=$$EDATE^PXRMDATE(VDATE)
-        . S LVL=$G(IFIEVAL(IND,"VALUE"))
-        . I LVL'="" D
-        .. S TEMP=TEMP_" level/severity - "
-        .. S TEMP=TEMP_$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        . I IFIEVAL(IND,"COMMENTS")'="" D
-        .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
-        .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;=====================================================
-WARN(HF0)       ;Issue a warning if a health factor is missing its category.
-        N XMSUB
-        K ^TMP("PXRMXMZ",$J)
-        S XMSUB="CLINICAL REMINDER DATA PROBLEM, HEALTH FACTOR"
-        S ^TMP("PXRMXMZ",$J,1,0)="Health Factor "_$P(HF0,U,1)
-        S ^TMP("PXRMXMZ",$J,2,0)="does not have a category, this is a required field."
-        S ^TMP("PXRMXMZ",$J,3,0)="This health factor will be ignored for all patients until the problem is fixed."
-        D SEND^PXRMMSG(XMSUB)
-        Q
-        ;
+PXRMHF ; SLC/PKR - Handle Health Factor findings. ;12/23/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;=====================================================
+CATSORT(FIEVAL,FIND0,FARR) ;Sort all the true health factor findings
+ ;according to the category criteria. FIND0 will be defined only
+ ;for terms.
+ N CAT,CATLIST,DATE,IND,FI,HFIEN,LDATE,NTRUE,WCR
+ S HFIEN=""
+ F  S HFIEN=$O(FARR("E","AUTTHF(",HFIEN)) Q:HFIEN=""  D
+ . S FI=0
+ . F  S FI=$O(FARR("E","AUTTHF(",HFIEN,FI)) Q:FI=""  D
+ .. I 'FIEVAL(FI) Q
+ ..;Get the Within Category Rank
+ .. S WCR=$P(FARR(20,FI,0),U,10)
+ .. I WCR="" S WCR=$P(FIND0,U,10)
+ .. I WCR="" S WCR=9999
+ ..;If Within Category Rank is 0 ignore the category and treat it like
+ ..;regular finding (exclude it from the list).
+ .. I WCR>0 D
+ ... S CAT=$P(^AUTTHF(HFIEN,0),U,3)
+ ...;If the category is null then send a warning.
+ ... I CAT="" D WARN(^AUTTHF(HFIEN,0))  Q
+ ... S CATLIST(CAT,FIEVAL(FI,"DATE"),WCR,FI)=""
+ ... I $G(PXRMDEBG) S FIEVAL(FI,"CAT^WCR")=CAT_U_WCR
+ ;No health factors to categorize then quit.
+ I '$D(CATLIST) Q
+ ;Only the most recent HF in a category can be true.
+ S CAT=""
+ F  S CAT=$O(CATLIST(CAT)) Q:CAT=""  D
+ . S LDATE=$O(CATLIST(CAT,""),-1)
+ .;For each category set all but the most recent HF false.
+ . S DATE=""
+ . F  S DATE=$O(CATLIST(CAT,DATE)) Q:DATE=LDATE  D
+ .. S WCR=""
+ .. F  S WCR=$O(CATLIST(CAT,DATE,WCR)) Q:WCR=""  D
+ ... S FI=""
+ ... F  S FI=$O(CATLIST(CAT,DATE,WCR,FI)) Q:FI=""  D
+ .... S FIEVAL(FI)=0
+ ....;If there are multiple occurrences set them all false.
+ .... S IND=0
+ .... F  S IND=+$O(FIEVAL(FI,IND)) Q:IND=0  S FIEVAL(FI,IND)=0
+ .;
+ .;If there is more than on HF on the most recent date then only the
+ .;one with the highest WCR can be true. The highest possible WCR is 1.
+ .;Set all with lower WCRs false.
+ .;If the most recent health factor has multiple occurrences only
+ .;the first occurrence can be true.
+ . S (NTRUE,WCR)=0
+ . F  S WCR=$O(CATLIST(CAT,LDATE,WCR)) Q:WCR=""  D
+ .. S FI=""
+ .. F  S FI=$O(CATLIST(CAT,LDATE,WCR,FI)) Q:FI=""  D
+ ... I NTRUE=0 D  Q
+ ....;If there are multiple sub-occurrences set them all false.
+ .... S (IND,NTRUE)=1
+ .... F  S IND=+$O(FIEVAL(FI,IND)) Q:IND=0  S FIEVAL(FI,IND)=0
+ ... S FIEVAL(FI)=0
+ ...;If there are multiple sub-occurrences set them all false.
+ ... S IND=0
+ ... F  S IND=+$O(FIEVAL(FI,IND)) Q:IND=0  S FIEVAL(FI,IND)=0
+ Q
+ ;
+ ;=====================================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate health factor findings.
+ N FIEVT,FILENUM,FINDPA,FINDING,HFIEN,NOINDEX
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
+ . S NOINDEX=1
+ E  S NOINDEX=0
+ S HFIEN=""
+ F  S HFIEN=$O(DEFARR("E",ENODE,HFIEN)) Q:+HFIEN=0  D
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,HFIEN,FINDING)) Q:+FINDING=0  D
+ .. I NOINDEX S FIEVAL(FINDING)=0 Q
+ .. K FINDPA
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. K FIEVT
+ .. D FIEVAL^PXRMINDX(FILENUM,"PI",DFN,HFIEN,.FINDPA,.FIEVT)
+ .. M FIEVAL(FINDING)=FIEVT
+ .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
+ ;Sort all the true true findings by category.
+ D CATSORT(.FIEVAL,"",.DEFARR)
+ Q
+ ;
+ ;=====================================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate health factor term findings
+ ;for patient lists.
+ D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
+ Q
+ ;
+ ;=====================================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate health factor terms.
+ N BDT,EDT,FIEVT,HFIEN,NOINDEX,PFINDPA
+ N TFINDPA,TFINDING
+ I $G(^PXRMINDX(9000010.23,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),9000010.23)
+ . S NOINDEX=1
+ E  S NOINDEX=0
+ S HFIEN=""
+ F  S HFIEN=$O(TERMARR("E",ENODE,HFIEN)) Q:+HFIEN=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,HFIEN,TFINDING)) Q:+TFINDING=0  D
+ .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
+ .. K FIEVT,PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D FIEVAL^PXRMINDX(9000010.23,"PI",DFN,HFIEN,.PFINDPA,.FIEVT)
+ .. M TFIEVAL(TFINDING)=FIEVT
+ .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
+ ;Sort all the true true findings by category.
+ D CATSORT(.TFIEVAL,FINDPA(0),.TERMARR)
+ Q
+ ;
+ ;=====================================================
+GETDATA(DAS,FIEVT) ;Return data for a specified V Health Factor entry.
+ ;DBIA #4250
+ D VHF^PXPXRM(DAS,.FIEVT)
+ Q
+ ;
+ ;=====================================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N EM,FIEN,IND,JND,LVL,NAME,NOUT,PNAME,TEMP,TEXTOUT,VDATE
+ S FIEN=$P(IFIEVAL("FINDING"),";",1)
+ S PNAME=$P(^AUTTHF(FIEN,0),U,1)
+ S NAME="Health Factor: "_PNAME_" = "
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S LVL=$G(IFIEVAL(IND,"VALUE"))
+ . I LVL'="" S LVL=$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
+ . S VDATE=IFIEVAL(IND,"DATE")
+ . S TEMP=NAME_LVL_" ("_$$EDATE^PXRMDATE(VDATE)_")"
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;=====================================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ N EM,FIEN,IND,JND,LVL,NOUT,PNAME,TEMP,TEXTOUT,VDATE
+ S FIEN=$P(IFIEVAL("FINDING"),";",1)
+ S PNAME=$P(^AUTTHF(FIEN,0),U,1)
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Health Factor: "_PNAME
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S VDATE=IFIEVAL(IND,"DATE")
+ . S TEMP=$$EDATE^PXRMDATE(VDATE)
+ . S LVL=$G(IFIEVAL(IND,"VALUE"))
+ . I LVL'="" D
+ .. S TEMP=TEMP_" level/severity - "
+ .. S TEMP=TEMP_$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM)
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ . I IFIEVAL(IND,"COMMENTS")'="" D
+ .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
+ .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;=====================================================
+WARN(HF0) ;Issue a warning if a health factor is missing its category.
+ N XMSUB
+ K ^TMP("PXRMXMZ",$J)
+ S XMSUB="CLINICAL REMINDER DATA PROBLEM, HEALTH FACTOR"
+ S ^TMP("PXRMXMZ",$J,1,0)="Health Factor "_$P(HF0,U,1)
+ S ^TMP("PXRMXMZ",$J,2,0)="does not have a category, this is a required field."
+ S ^TMP("PXRMXMZ",$J,3,0)="This health factor will be ignored for all patients until the problem is fixed."
+ D SEND^PXRMMSG(XMSUB)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m

@@ -1 @@
-PXRMINDC        ; SLC/PKR - Index counting routines. ;03/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;========================================================
-CNT5(FILENUM,COUNT)     ;Get date counts for indexes where the date
-        ;is at subscript 5. Works for file numbers:
-        ;63, 70, 120.5, 601.2, 601.84,
-        ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
-        N DAS,DATE,DFN,IND,ITEM,YEAR
-        I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S ITEM=""
-        . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
-        .. S DATE=""
-        .. F  S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
-        ... S YEAR=$E(DATE,1,3)
-        ... S DAS=""
-        ... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS=""  D
-        .... S COUNT(YEAR)=$G(COUNT(YEAR))+1
-        Q
-        ;
-        ;========================================================
-CNT6(FILENUM,COUNT)     ;Get date counts for indexes where the date
-        ;is at subscript 6. Works for file numbers:
-        ;9000010.07, 9000010.18
-        N DAS,DATE,DFN,IND,ITEM,TYPE,YEAR
-        I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S TYPE=""
-        . F  S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE=""  D
-        .. S ITEM=""
-        .. F  S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM=""  D
-        ... S DATE=""
-        ... F  S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
-        .... S YEAR=$E(DATE,1,3)
-        .... S DAS=""
-        .... F  S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS=""  D
-        ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1
-        Q
-        ;
-        ;========================================================
-CNTPL(FILENUM,COUNT)    ;Get date counts for Problem List indexes where the
-        ;date is at subscript 7. Works for file numbers:
-        ;9000011
-        N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE,YEAR
-        I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S STATUS=""
-        . F  S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS=""  D
-        .. S PRIORITY=""
-        .. F  S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
-        ... S ITEM=""
-        ... F  S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM=""  D
-        .... S DATE=""
-        .... F  S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
-        ..... S YEAR=$E(DATE,1,3)
-        ..... S DAS=""
-        ..... F  S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS=""  D
-        ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1
-        Q
-        ;
-        ;========================================================
-CNTPTF(FILENUM,COUNT)   ;Get date counts for PTF indexes where the
-        ;date is at subscript 7. Works for file numbers:
-        ;45
-        N DAS,DATE,DFN,IND,ITEM,NODE,TYPE,YEAR
-        I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
-        S IND=0
-        F TYPE="ICD0","ICD9" D
-        . S DFN=""
-        . F  S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN=""  D
-        .. S IND=IND+1
-        .. I '$D(ZTQUEUED),(IND#10000=0) W "."
-        .. S NODE=""
-        .. F  S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE=""  D
-        ... S ITEM=""
-        ... F  S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM=""  D
-        .... S DATE=""
-        .... F  S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE=""  D
-        ..... S YEAR=$E(DATE,1,3)
-        ..... S DAS=""
-        ..... F  S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS=""  D
-        ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1
-        Q
-        ;
-        ;========================================================
-CNTSS(FILENUM,COUNT)    ;Get date counts for indexes where the start date
-        ;is at subscript 5 and the stop date is at subscript 6.
-        ;Works for file numbers: 52, 55, 100
-        N DAS,DFN,IND,ITEM,START,STOP,YEAR
-        I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S ITEM=""
-        . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
-        .. S START=""
-        .. F  S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START=""  D
-        ... S YEAR=$E(START,1,3)
-        ... S STOP=""
-        ... F  S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP=""  D
-        .... S DAS=""
-        .... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS=""  D
-        ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1
-        Q
-        ;
-        ;========================================================
-COUNT   ;Driver for making index counts.
-        N GBL,LIST,TASKIT
-        W !,"Which indexes do you want to count?"
-        D SEL^PXRMSXRM(.LIST,.GBL)
-        I LIST="" Q
-        ;See if this should be tasked.
-        S TASKIT=$$ASKTASK^PXRMSXRM
-        I TASKIT D
-        . W !,"Queue the Clinical Reminders Index count."
-        . D TASKIT(LIST,.GBL,.ROUTINE)
-        E  D RUNNOW(LIST,.GBL)
-        Q
-        ;
-        ;========================================================
-MESSAGE(FILENUM,COUNT,TOTAL,START,END)  ;Build the MailMan message giving the
-        ;count breakdown.
-        N COFF,ML,NAME,NL,PERC,TEXT,YEAR,XMSUB
-        K ^TMP("PXRMXMZ",$J)
-        S ML=$$MAX^XLFMTH($L(TOTAL)+2,8)
-        S COFF=ML-5
-        S NAME=$$GET1^DID(FILENUM,"","","NAME")
-        S XMSUB="Yearly data distribution for global "_NAME
-        S ^TMP("PXRMXMZ",$J,1,0)="File name: "_NAME
-        S ^TMP("PXRMXMZ",$J,2,0)="Count finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END)
-        S ^TMP("PXRMXMZ",$J,4,0)=" "
-        S ^TMP("PXRMXMZ",$J,5,0)="Year"_$$INSCHR^PXRMEXLC(COFF," ")_"Count"_$J("%",8)
-        S ^TMP("PXRMXMZ",$J,6,0)="----"_$$INSCHR^PXRMEXLC(COFF," ")_"-----"_$J("-----",10)
-        S NL=6,YEAR=0
-        F  S YEAR=$O(COUNT(YEAR)) Q:YEAR=""  D
-        . S PERC=100*COUNT(YEAR)/TOTAL
-        . S TEXT=YEAR_$J(COUNT(YEAR),ML,0)_$J(PERC,10,2)
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "
-        S TEXT="Total entries: "_TOTAL
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
-        I TOTAL=0 D
-        . I '$D(^PXRMINDX(FILENUM)) S TEXT="The index for file "_NAME_" does not exist!"
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
-        I TOTAL>0,'$D(^PXRMINDX(FILENUM,"DATE BUILT")) D
-        . S TEXT="Warning, the index for file "_NAME_" may be incomplete or corrupted!"
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
-        D SEND^PXRMMSG(XMSUB)
-        K ^TMP("PXRMXMZ",$J)
-        Q
-        ;
-        ;===============================================================
-RUNNOW(LIST,GBL)        ;Run the routines now.
-        N COUNT,END,FN,IND,LI,NUM,ROUTINE,RTN,START,TOTAL
-        S ROUTINE(45)="CNTPTF^PXRMINDC"
-        S ROUTINE(52)="CNTSS^PXRMINDC"
-        S ROUTINE(55)="CNTSS^PXRMINDC"
-        S ROUTINE(63)="CNT5^PXRMINDC"
-        S ROUTINE(70)="CNT5^PXRMINDC"
-        S ROUTINE(100)="CNTSS^PXRMINDC"
-        S ROUTINE(120.5)="CNT5^PXRMINDC"
-        S ROUTINE(601.2)="CNT5^PXRMINDC"
-        S ROUTINE(601.84)="CNT5^PXRMINDC"
-        S ROUTINE(9000011)="CNTPL^PXRMINDC"
-        S ROUTINE(9000010.07)="CNT6^PXRMINDC"
-        S ROUTINE(9000010.11)="CNT5^PXRMINDC"
-        S ROUTINE(9000010.12)="CNT5^PXRMINDC"
-        S ROUTINE(9000010.13)="CNT5^PXRMINDC"
-        S ROUTINE(9000010.16)="CNT5^PXRMINDC"
-        S ROUTINE(9000010.18)="CNT6^PXRMINDC"
-        S ROUTINE(9000010.23)="CNT5^PXRMINDC"
-        S NUM=$L(LIST,",")-1
-        F IND=1:1:NUM D
-        . S LI=$P(LIST,",",IND)
-        . S FN=GBL(LI)
-        . S RTN=ROUTINE(FN)
-        . S RTN=RTN_"("_FN_",.COUNT)"
-        . S START=$H
-        . K COUNT
-        . I $D(^PXRMINDX(FN)) D @RTN
-        . S END=$H
-        . D TOTAL(.COUNT,.TOTAL)
-        . D MESSAGE(FN,.COUNT,TOTAL,START,END)
-        Q
-        ;
-        ;===============================================================
-TASKIT(LIST,GBL,ROUTINE)        ;Count the indexes as a tasked job.
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S SDTIME=Y
-        K DIR
-        ;Put the task into the queue.
-        K ZTSAVE
-        S ZTSAVE("LIST")=""
-        S ZTSAVE("GBL(")=""
-        S ZTRTN="TASKJOB^PXRMINDC"
-        S ZTDESC="Clinical Reminders Index count"
-        S ZTDTH=SDTIME
-        S ZTIO=""
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued."
-        Q
-        ;
-        ;===============================================================
-TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE.
-        N IND,LI,NUM
-        S ZTREQ="@"
-        S ZTSTOP=0
-        S NUM=$L(LIST,",")-1
-        F IND=1:1:NUM D
-        .;Check to see if the task has had a stop request
-        . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
-        . S LI=$P(LIST,",",IND)_","
-        . D RUNNOW^PXRMINDC(LI,.GBL)
-        Q
-        ;
-        ;========================================================
-TOTAL(COUNT,TOTAL)      ;Convert the FileMan years in COUNT to regular
-        ;years get the total number of entries in count.
-        N TC,YEAR
-        S (TOTAL,YEAR)=0
-        F  S YEAR=$O(COUNT(YEAR)) Q:YEAR=""  D
-        . S TOTAL=TOTAL+COUNT(YEAR)
-        . S TC(YEAR+1700)=COUNT(YEAR)
-        K COUNT
-        M COUNT=TC
-        Q
-        ;
+PXRMINDC ; SLC/PKR - Index counting routines. ;04/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;========================================================
+CNT5(FILENUM,COUNT) ;Get date counts for indexes where the date
+ ;is at subscript 5. Works for file numbers:
+ ;63, 70, 120.5, 601.2,
+ ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
+ N DAS,DATE,DFN,IND,ITEM,YEAR
+ I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S ITEM=""
+ . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
+ .. S DATE=""
+ .. F  S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
+ ... S YEAR=$E(DATE,1,3)
+ ... S DAS=""
+ ... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS=""  D
+ .... S COUNT(YEAR)=$G(COUNT(YEAR))+1
+ Q
+ ;
+ ;========================================================
+CNT6(FILENUM,COUNT) ;Get date counts for indexes where the date
+ ;is at subscript 6. Works for file numbers:
+ ;9000010.07, 9000010.18
+ N DAS,DATE,DFN,IND,ITEM,TYPE,YEAR
+ I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S TYPE=""
+ . F  S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE=""  D
+ .. S ITEM=""
+ .. F  S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM=""  D
+ ... S DATE=""
+ ... F  S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
+ .... S YEAR=$E(DATE,1,3)
+ .... S DAS=""
+ .... F  S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS=""  D
+ ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1
+ Q
+ ;
+ ;========================================================
+CNTPL(FILENUM,COUNT) ;Get date counts for Problem List indexes where the
+ ;date is at subscript 7. Works for file numbers:
+ ;9000011
+ N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE,YEAR
+ I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S STATUS=""
+ . F  S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS=""  D
+ .. S PRIORITY=""
+ .. F  S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
+ ... S ITEM=""
+ ... F  S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM=""  D
+ .... S DATE=""
+ .... F  S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
+ ..... S YEAR=$E(DATE,1,3)
+ ..... S DAS=""
+ ..... F  S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS=""  D
+ ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1
+ Q
+ ;
+ ;========================================================
+CNTPTF(FILENUM,COUNT) ;Get date counts for PTF indexes where the
+ ;date is at subscript 7. Works for file numbers:
+ ;45
+ N DAS,DATE,DFN,IND,ITEM,NODE,TYPE,YEAR
+ I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
+ S IND=0
+ F TYPE="ICD0","ICD9" D
+ . S DFN=""
+ . F  S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN=""  D
+ .. S IND=IND+1
+ .. I '$D(ZTQUEUED),(IND#10000=0) W "."
+ .. S NODE=""
+ .. F  S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE=""  D
+ ... S ITEM=""
+ ... F  S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM=""  D
+ .... S DATE=""
+ .... F  S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE=""  D
+ ..... S YEAR=$E(DATE,1,3)
+ ..... S DAS=""
+ ..... F  S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS=""  D
+ ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1
+ Q
+ ;
+ ;========================================================
+CNTSS(FILENUM,COUNT) ;Get date counts for indexes where the start date
+ ;is at subscript 5 and the stop date is at subscript 6.
+ ;Works for file numbers: 52, 55, 100
+ N DAS,DFN,IND,ITEM,START,STOP,YEAR
+ I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S ITEM=""
+ . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
+ .. S START=""
+ .. F  S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START=""  D
+ ... S YEAR=$E(START,1,3)
+ ... S STOP=""
+ ... F  S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP=""  D
+ .... S DAS=""
+ .... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS=""  D
+ ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1
+ Q
+ ;
+ ;========================================================
+COUNT ;Driver for making index counts.
+ N GBL,LIST,TASKIT
+ W !,"Which indexes do you want to count?"
+ D SEL^PXRMSXRM(.LIST,.GBL)
+ I LIST="" Q
+ ;See if this should be tasked.
+ S TASKIT=$$ASKTASK^PXRMSXRM
+ I TASKIT D
+ . W !,"Queue the Clinical Reminders Index count."
+ . D TASKIT(LIST,.GBL,.ROUTINE)
+ E  D RUNNOW(LIST,.GBL)
+ Q
+ ;
+ ;========================================================
+MESSAGE(FILENUM,COUNT,TOTAL,START,END) ;Build the MailMan message giving the
+ ;count breakdown.
+ N COFF,ML,NAME,NL,PERC,TEXT,YEAR,XMSUB
+ K ^TMP("PXRMXMZ",$J)
+ S ML=$$MAX^XLFMTH($L(TOTAL)+2,8)
+ S COFF=ML-5
+ S NAME=$$GET1^DID(FILENUM,"","","NAME")
+ S XMSUB="Yearly data distribution for global "_NAME
+ S ^TMP("PXRMXMZ",$J,1,0)="File name: "_NAME
+ S ^TMP("PXRMXMZ",$J,2,0)="Count finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END)
+ S ^TMP("PXRMXMZ",$J,4,0)=" "
+ S ^TMP("PXRMXMZ",$J,5,0)="Year"_$$INSCHR^PXRMEXLC(COFF," ")_"Count"_$J("%",8)
+ S ^TMP("PXRMXMZ",$J,6,0)="----"_$$INSCHR^PXRMEXLC(COFF," ")_"-----"_$J("-----",10)
+ S NL=6,YEAR=0
+ F  S YEAR=$O(COUNT(YEAR)) Q:YEAR=""  D
+ . S PERC=100*COUNT(YEAR)/TOTAL
+ . S TEXT=YEAR_$J(COUNT(YEAR),ML,0)_$J(PERC,10,2)
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "
+ S TEXT="Total entries: "_TOTAL
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
+ I TOTAL=0 D
+ . I '$D(^PXRMINDX(FILENUM)) S TEXT="The index for file "_NAME_" does not exist!"
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
+ I TOTAL>0,'$D(^PXRMINDX(FILENUM,"DATE BUILT")) D
+ . S TEXT="Warning, the index for file "_NAME_" may be incomplete or corrupted!"
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT
+ D SEND^PXRMMSG(XMSUB)
+ K ^TMP("PXRMXMZ",$J)
+ Q
+ ;
+ ;===============================================================
+RUNNOW(LIST,GBL) ;Run the routines now.
+ N COUNT,END,FN,IND,LI,NUM,ROUTINE,RTN,START,TOTAL
+ S ROUTINE(45)="CNTPTF^PXRMINDC"
+ S ROUTINE(52)="CNTSS^PXRMINDC"
+ S ROUTINE(55)="CNTSS^PXRMINDC"
+ S ROUTINE(63)="CNT5^PXRMINDC"
+ S ROUTINE(70)="CNT5^PXRMINDC"
+ S ROUTINE(100)="CNTSS^PXRMINDC"
+ S ROUTINE(120.5)="CNT5^PXRMINDC"
+ S ROUTINE(601.2)="CNT5^PXRMINDC"
+ S ROUTINE(9000011)="CNTPL^PXRMINDC"
+ S ROUTINE(9000010.07)="CNT6^PXRMINDC"
+ S ROUTINE(9000010.11)="CNT5^PXRMINDC"
+ S ROUTINE(9000010.12)="CNT5^PXRMINDC"
+ S ROUTINE(9000010.13)="CNT5^PXRMINDC"
+ S ROUTINE(9000010.16)="CNT5^PXRMINDC"
+ S ROUTINE(9000010.18)="CNT6^PXRMINDC"
+ S ROUTINE(9000010.23)="CNT5^PXRMINDC"
+ S NUM=$L(LIST,",")-1
+ F IND=1:1:NUM D
+ . S LI=$P(LIST,",",IND)
+ . S FN=GBL(LI)
+ . S RTN=ROUTINE(FN)
+ . S RTN=RTN_"("_FN_",.COUNT)"
+ . S START=$H
+ . K COUNT
+ . I $D(^PXRMINDX(FN)) D @RTN
+ . S END=$H
+ . D TOTAL(.COUNT,.TOTAL)
+ . D MESSAGE(FN,.COUNT,TOTAL,START,END)
+ Q
+ ;
+ ;===============================================================
+TASKIT(LIST,GBL,ROUTINE) ;Count the indexes as a tasked job.
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S SDTIME=Y
+ K DIR
+ ;Put the task into the queue.
+ K ZTSAVE
+ S ZTSAVE("LIST")=""
+ S ZTSAVE("GBL(")=""
+ S ZTRTN="TASKJOB^PXRMINDC"
+ S ZTDESC="Clinical Reminders Index count"
+ S ZTDTH=SDTIME
+ S ZTIO=""
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued."
+ Q
+ ;
+ ;===============================================================
+TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE.
+ N IND,LI,NUM
+ S ZTREQ="@"
+ S ZTSTOP=0
+ S NUM=$L(LIST,",")-1
+ F IND=1:1:NUM D
+ .;Check to see if the task has had a stop request
+ . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
+ . S LI=$P(LIST,",",IND)_","
+ . D RUNNOW^PXRMINDC(LI,.GBL)
+ Q
+ ;
+ ;========================================================
+TOTAL(COUNT,TOTAL) ;Convert the FileMan years in COUNT to regular
+ ;years get the total number of entries in count.
+ N TC,YEAR
+ S (TOTAL,YEAR)=0
+ F  S YEAR=$O(COUNT(YEAR)) Q:YEAR=""  D
+ . S TOTAL=TOTAL+COUNT(YEAR)
+ . S TC(YEAR+1700)=COUNT(YEAR)
+ K COUNT
+ M COUNT=TC
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m

@@ -1 @@
-PXRMINDD        ; SLC/PKR - Index string date checking routines. ;03/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;========================================================
-CNT5(FILENUM,NSD)       ;Check for string dates for indexes where the date
-        ;is at subscript 5. Works for file numbers:
-        ;63, 70, 120.5, 601.2, 601.84
-        ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
-        N DAS,DATE,DFN,IND,ITEM
-        I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S ITEM=""
-        . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
-        .. S DATE=""
-        .. F  S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
-        ... I +DATE=DATE Q
-        ... S DAS=""
-        ... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS=""  D
-        .... S NSD=NSD+1
-        .... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_DATE_""","_DAS_")"
-        Q
-        ;
-        ;========================================================
-CNT6(FILENUM,NSD)       ;Check for string dates for indexes where the date
-        ;is at subscript 6. Works for file numbers:
-        ;9000010.07, 9000010.18
-        N DAS,DATE,DFN,IND,ITEM,TYPE
-        I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S TYPE=""
-        . F  S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE=""  D
-        .. S ITEM=""
-        .. F  S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM=""  D
-        ... S DATE=""
-        ... F  S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
-        .... I +DATE=DATE Q
-        .... S DAS=""
-        .... F  S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS=""  D
-        ..... S NSD=NSD+1
-        ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PPI"","_DFN_","_TYPE_","_ITEM_","""_DATE_""","_DAS_")"
-        Q
-        ;
-        ;========================================================
-CNTPL(FILENUM,NSD)      ;Check for string date for Problem List indexes where the
-        ;date is at subscript 7. Works for file numbers:
-        ;9000011
-        N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE
-        I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S STATUS=""
-        . F  S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS=""  D
-        .. S PRIORITY=""
-        .. F  S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
-        ... S ITEM=""
-        ... F  S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM=""  D
-        .... S DATE=""
-        .... F  S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
-        ..... I +DATE=DATE Q
-        ..... S DAS=""
-        ..... F  S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS=""  D
-        ...... S NSD=NSD+1
-        ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PSPI"","_DFN_","_STATUS_","_PRIORITY_","_ITEM_","""_DATE_""","_DAS_")"
-        Q
-        ;
-        ;========================================================
-CNTPTF(FILENUM,NSD)     ;Check for string dates for PTF indexes where the
-        ;date is at subscript 7. Works for file numbers:
-        ;45
-        N DAS,DATE,DFN,IND,ITEM,NODE,TYPE
-        I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
-        S IND=0
-        F TYPE="ICD0","ICD9" D
-        . S DFN=""
-        . F  S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN=""  D
-        .. S IND=IND+1
-        .. I '$D(ZTQUEUED),(IND#10000=0) W "."
-        .. S NODE=""
-        .. F  S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE=""  D
-        ... S ITEM=""
-        ... F  S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM=""  D
-        .... S DATE=""
-        .... F  S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE=""  D
-        ..... I +DATE=DATE Q
-        ..... S DAS=""
-        ..... F  S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS=""  D
-        ...... S NSD=NSD+1
-        ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_","_TYPE_",""PNI"","_DFN_","_NODE_","_ITEM_","""_DATE_""","_DAS_")"
-        Q
-        ;
-        ;========================================================
-CNTSS(FILENUM,NSD)      ;Check for string dates for indexes where the start date
-        ;is at subscript 5 and the stop date is at subscript 6.
-        ;Works for file numbers: 52, 55, 100
-        N DAS,DFN,IND,ITEM,START,STOP
-        I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
-        S IND=0
-        S DFN=""
-        F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
-        . S IND=IND+1
-        . I '$D(ZTQUEUED),(IND#10000=0) W "."
-        . S ITEM=""
-        . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
-        .. S START=""
-        .. F  S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START=""  D
-        ... I +START=START Q
-        ... S STOP=""
-        ... F  S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP=""  D
-        .... S DAS=""
-        .... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS=""  D
-        ..... S NSD=NSD+1
-        ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_START_""","_STOP_","_DAS_")"
-        Q
-        ;
-        ;========================================================
-CHECK   ;Driver for making index date checks.
-        N GBL,LIST,TASKIT
-        W !,"Which indexes do you want to check?"
-        D SEL^PXRMSXRM(.LIST,.GBL)
-        I LIST="" Q
-        ;See if this should be tasked.
-        S TASKIT=$$ASKTASK^PXRMSXRM
-        I TASKIT D
-        . W !,"Queue the Clinical Reminders Index date check."
-        . D TASKIT(LIST,.GBL,.ROUTINE)
-        E  D RUNNOW(LIST,.GBL)
-        Q
-        ;
-        ;========================================================
-MESSAGE(FILENUM,NSD,START,END)  ;Build the MailMan message giving the
-        ;list of entries with string dates.
-        N IND,NAME,NL,TEXT,XMSUB
-        K ^TMP("PXRMXMZ",$J)
-        S XMSUB="CR Index string date check for file #"_FILENUM
-        S NAME=$$GET1^DID(FILENUM,"","","NAME")_", file #"_FILENUM
-        I NSD=0 S TEXT="No string dates were found for "_NAME_"."
-        I NSD>0 S TEXT="A total of "_NSD_" string dates were found for "_NAME_"."
-        S ^TMP("PXRMXMZ",$J,1,0)=TEXT
-        S ^TMP("PXRMXMZ",$J,2,0)="Check finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END)
-        S ^TMP("PXRMXMZ",$J,4,0)=" "
-        I NSD=0,'$D(^PXRMINDX(FILENUM)) D
-        . S ^TMP("PXRMXMZ",$J,5,0)="The index for file number "_FILENUM_" does not exist."
-        . S ^TMP("PXRMXMZ",$J,6,0)=" "
-        I NSD>0 D
-        . S ^TMP("PXRMXMZ",$J,5,0)="The following entries with string dates were found:"
-        . S NL=5
-        . F IND=1:1:NSD D
-        .. S NL=NL+1
-        .. S ^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDATE",IND)
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "
-        D SEND^PXRMMSG(XMSUB)
-        K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J)
-        Q
-        ;
-        ;===============================================================
-RUNNOW(LIST,GBL)        ;Run the routines now.
-        N END,FN,IND,LI,NSD,NUM,ROUTINE,RTN,START,TOTAL
-        K ^TMP($J,"SDATE")
-        S ROUTINE(45)="CNTPTF^PXRMINDD"
-        S ROUTINE(52)="CNTSS^PXRMINDD"
-        S ROUTINE(55)="CNTSS^PXRMINDD"
-        S ROUTINE(63)="CNT5^PXRMINDD"
-        S ROUTINE(70)="CNT5^PXRMINDD"
-        S ROUTINE(100)="CNTSS^PXRMINDD"
-        S ROUTINE(120.5)="CNT5^PXRMINDD"
-        S ROUTINE(601.2)="CNT5^PXRMINDD"
-        S ROUTINE(601.84)="CNT5^PXRMINDD"
-        S ROUTINE(9000011)="CNTPL^PXRMINDD"
-        S ROUTINE(9000010.07)="CNT6^PXRMINDD"
-        S ROUTINE(9000010.11)="CNT5^PXRMINDD"
-        S ROUTINE(9000010.12)="CNT5^PXRMINDD"
-        S ROUTINE(9000010.13)="CNT5^PXRMINDD"
-        S ROUTINE(9000010.16)="CNT5^PXRMINDD"
-        S ROUTINE(9000010.18)="CNT6^PXRMINDD"
-        S ROUTINE(9000010.23)="CNT5^PXRMINDD"
-        S NUM=$L(LIST,",")-1
-        F IND=1:1:NUM D
-        . S LI=$P(LIST,",",IND)
-        . S NSD=0
-        . S FN=GBL(LI)
-        . S RTN=ROUTINE(FN)
-        . S RTN=RTN_"("_FN_",.NSD)"
-        . S START=$H
-        . I $D(^PXRMINDX(FN)) D @RTN
-        . S END=$H
-        . D MESSAGE(FN,NSD,START,END)
-        Q
-        ;
-        ;===============================================================
-TASKIT(LIST,GBL,ROUTINE)        ;Check the indexes as a tasked job.
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S SDTIME=Y
-        K DIR
-        ;Put the task into the queue.
-        K ZTSAVE
-        S ZTSAVE("LIST")=""
-        S ZTSAVE("GBL(")=""
-        S ZTRTN="TASKJOB^PXRMINDD"
-        S ZTDESC="Clinical Reminders Index string date check"
-        S ZTDTH=SDTIME
-        S ZTIO=""
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued."
-        Q
-        ;
-        ;===============================================================
-TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE.
-        N IND,LI,NUM
-        S ZTREQ="@"
-        S ZTSTOP=0
-        S NUM=$L(LIST,",")-1
-        F IND=1:1:NUM D
-        .;Check to see if the task has had a stop request
-        . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
-        . S LI=$P(LIST,",",IND)_","
-        . D RUNNOW^PXRMINDD(LI,.GBL)
-        Q
-        ;
+PXRMINDD ; SLC/PKR - Index string date checking routines. ;05/02/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;========================================================
+CNT5(FILENUM,NSD) ;Check for string dates for indexes where the date
+ ;is at subscript 5. Works for file numbers:
+ ;63, 70, 120.5, 601.2,
+ ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
+ N DAS,DATE,DFN,IND,ITEM
+ I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S ITEM=""
+ . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
+ .. S DATE=""
+ .. F  S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE=""  D
+ ... I +DATE=DATE Q
+ ... S DAS=""
+ ... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS=""  D
+ .... S NSD=NSD+1
+ .... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_DATE_""","_DAS_")"
+ Q
+ ;
+ ;========================================================
+CNT6(FILENUM,NSD) ;Check for string dates for indexes where the date
+ ;is at subscript 6. Works for file numbers:
+ ;9000010.07, 9000010.18
+ N DAS,DATE,DFN,IND,ITEM,TYPE
+ I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S TYPE=""
+ . F  S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE=""  D
+ .. S ITEM=""
+ .. F  S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM=""  D
+ ... S DATE=""
+ ... F  S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE=""  D
+ .... I +DATE=DATE Q
+ .... S DAS=""
+ .... F  S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS=""  D
+ ..... S NSD=NSD+1
+ ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PPI"","_DFN_","_TYPE_","_ITEM_","""_DATE_""","_DAS_")"
+ Q
+ ;
+ ;========================================================
+CNTPL(FILENUM,NSD) ;Check for string date for Problem List indexes where the
+ ;date is at subscript 7. Works for file numbers:
+ ;9000011
+ N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE
+ I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S STATUS=""
+ . F  S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS=""  D
+ .. S PRIORITY=""
+ .. F  S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY=""  D
+ ... S ITEM=""
+ ... F  S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM=""  D
+ .... S DATE=""
+ .... F  S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE=""  D
+ ..... I +DATE=DATE Q
+ ..... S DAS=""
+ ..... F  S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS=""  D
+ ...... S NSD=NSD+1
+ ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PSPI"","_DFN_","_STATUS_","_PRIORITY_","_ITEM_","""_DATE_""","_DAS_")"
+ Q
+ ;
+ ;========================================================
+CNTPTF(FILENUM,NSD) ;Check for string dates for PTF indexes where the
+ ;date is at subscript 7. Works for file numbers:
+ ;45
+ N DAS,DATE,DFN,IND,ITEM,NODE,TYPE
+ I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
+ S IND=0
+ F TYPE="ICD0","ICD9" D
+ . S DFN=""
+ . F  S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN=""  D
+ .. S IND=IND+1
+ .. I '$D(ZTQUEUED),(IND#10000=0) W "."
+ .. S NODE=""
+ .. F  S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE=""  D
+ ... S ITEM=""
+ ... F  S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM=""  D
+ .... S DATE=""
+ .... F  S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE=""  D
+ ..... I +DATE=DATE Q
+ ..... S DAS=""
+ ..... F  S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS=""  D
+ ...... S NSD=NSD+1
+ ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_","_TYPE_",""PNI"","_DFN_","_NODE_","_ITEM_","""_DATE_""","_DAS_")"
+ Q
+ ;
+ ;========================================================
+CNTSS(FILENUM,NSD) ;Check for string dates for indexes where the start date
+ ;is at subscript 5 and the stop date is at subscript 6.
+ ;Works for file numbers: 52, 55, 100
+ N DAS,DFN,IND,ITEM,START,STOP
+ I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM
+ S IND=0
+ S DFN=""
+ F  S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN=""  D
+ . S IND=IND+1
+ . I '$D(ZTQUEUED),(IND#10000=0) W "."
+ . S ITEM=""
+ . F  S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM=""  D
+ .. S START=""
+ .. F  S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START=""  D
+ ... I +START=START Q
+ ... S STOP=""
+ ... F  S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP=""  D
+ .... S DAS=""
+ .... F  S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS=""  D
+ ..... S NSD=NSD+1
+ ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_START_""","_STOP_","_DAS_")"
+ Q
+ ;
+ ;========================================================
+CHECK ;Driver for making index date checks.
+ N GBL,LIST,TASKIT
+ W !,"Which indexes do you want to check?"
+ D SEL^PXRMSXRM(.LIST,.GBL)
+ I LIST="" Q
+ ;See if this should be tasked.
+ S TASKIT=$$ASKTASK^PXRMSXRM
+ I TASKIT D
+ . W !,"Queue the Clinical Reminders Index date check."
+ . D TASKIT(LIST,.GBL,.ROUTINE)
+ E  D RUNNOW(LIST,.GBL)
+ Q
+ ;
+ ;========================================================
+MESSAGE(FILENUM,NSD,START,END) ;Build the MailMan message giving the
+ ;list of entries with string dates.
+ N IND,NAME,NL,TEXT,XMSUB
+ K ^TMP("PXRMXMZ",$J)
+ S XMSUB="CR Index string date check for file #"_FILENUM
+ S NAME=$$GET1^DID(FILENUM,"","","NAME")_", file #"_FILENUM
+ I NSD=0 S TEXT="No string dates were found for "_NAME_"."
+ I NSD>0 S TEXT="A total of "_NSD_" string dates were found for "_NAME_"."
+ S ^TMP("PXRMXMZ",$J,1,0)=TEXT
+ S ^TMP("PXRMXMZ",$J,2,0)="Check finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END)
+ S ^TMP("PXRMXMZ",$J,4,0)=" "
+ I NSD=0,'$D(^PXRMINDX(FILENUM)) D
+ . S ^TMP("PXRMXMZ",$J,5,0)="The index for file number "_FILENUM_" does not exist."
+ . S ^TMP("PXRMXMZ",$J,6,0)=" "
+ I NSD>0 D
+ . S ^TMP("PXRMXMZ",$J,5,0)="The following entries with string dates were found:"
+ . S NL=5
+ . F IND=1:1:NSD D
+ .. S NL=NL+1
+ .. S ^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDATE",IND)
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "
+ D SEND^PXRMMSG(XMSUB)
+ K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J)
+ Q
+ ;
+ ;===============================================================
+RUNNOW(LIST,GBL) ;Run the routines now.
+ N END,FN,IND,LI,NSD,NUM,ROUTINE,RTN,START,TOTAL
+ K ^TMP($J,"SDATE")
+ S ROUTINE(45)="CNTPTF^PXRMINDD"
+ S ROUTINE(52)="CNTSS^PXRMINDD"
+ S ROUTINE(55)="CNTSS^PXRMINDD"
+ S ROUTINE(63)="CNT5^PXRMINDD"
+ S ROUTINE(70)="CNT5^PXRMINDD"
+ S ROUTINE(100)="CNTSS^PXRMINDD"
+ S ROUTINE(120.5)="CNT5^PXRMINDD"
+ S ROUTINE(601.2)="CNT5^PXRMINDD"
+ S ROUTINE(9000011)="CNTPL^PXRMINDD"
+ S ROUTINE(9000010.07)="CNT6^PXRMINDD"
+ S ROUTINE(9000010.11)="CNT5^PXRMINDD"
+ S ROUTINE(9000010.12)="CNT5^PXRMINDD"
+ S ROUTINE(9000010.13)="CNT5^PXRMINDD"
+ S ROUTINE(9000010.16)="CNT5^PXRMINDD"
+ S ROUTINE(9000010.18)="CNT6^PXRMINDD"
+ S ROUTINE(9000010.23)="CNT5^PXRMINDD"
+ S NUM=$L(LIST,",")-1
+ F IND=1:1:NUM D
+ . S LI=$P(LIST,",",IND)
+ . S NSD=0
+ . S FN=GBL(LI)
+ . S RTN=ROUTINE(FN)
+ . S RTN=RTN_"("_FN_",.NSD)"
+ . S START=$H
+ . I $D(^PXRMINDX(FN)) D @RTN
+ . S END=$H
+ . D MESSAGE(FN,NSD,START,END)
+ Q
+ ;
+ ;===============================================================
+TASKIT(LIST,GBL,ROUTINE) ;Check the indexes as a tasked job.
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S SDTIME=Y
+ K DIR
+ ;Put the task into the queue.
+ K ZTSAVE
+ S ZTSAVE("LIST")=""
+ S ZTSAVE("GBL(")=""
+ S ZTRTN="TASKJOB^PXRMINDD"
+ S ZTDESC="Clinical Reminders Index string date check"
+ S ZTDTH=SDTIME
+ S ZTIO=""
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued."
+ Q
+ ;
+ ;===============================================================
+TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE.
+ N IND,LI,NUM
+ S ZTREQ="@"
+ S ZTSTOP=0
+ S NUM=$L(LIST,",")-1
+ F IND=1:1:NUM D
+ .;Check to see if the task has had a stop request
+ . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
+ . S LI=$P(LIST,",",IND)_","
+ . D RUNNOW^PXRMINDD(LI,.GBL)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m

@@ -1 @@
-PXRMINDL        ; SLC/PKR - List building routines. ;07/26/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;================================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;General patient list term evaluator.
-        ;Return the list in ^TMP($J,PLIST)
-        N ITEM,FILENUM,PFINDPA
-        N SSFIND,TEMP,TFINDING,TFINDPA
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D  Q
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
-        S ITEM=""
-        F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:ITEM=""  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
-        .. K PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)
-        Q
-        ;
-        ;================================================
-FPLIST(FILENUM,SNODE,ITEM,NOCC,BDT,EDT,PLIST)   ;Find patient list data for
-        ;regular files. Return the list in ^TMP($J,PLIST).
-        N DAS,DATE,DFN,DS,NFOUND
-        K ^TMP($J,PLIST)
-        I FILENUM=601.84 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q
-        S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
-        S DFN=0
-        F  S DFN=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN)) Q:DFN=""  D
-        . S NFOUND=0
-        . S DATE=DS
-        . F  S DATE=+$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC)  D
-        .. S NFOUND=NFOUND+1
-        .. S DAS=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE,""))
-        .. S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE
-        Q
-        ;
-        ;================================================
-FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,PLIST) ;Find patient list
-        ;data for a finding with a start and stop date.
-        ;Return the list in ^TMP($J,PLIST).
-        N DAS,DFN,DONE,EDTT,NFOUND,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
-        K ^TMP($J,PLIST)
-        S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
-        S DFN=0
-        F  S DFN=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN)) Q:DFN=""  D
-        . S (DONE,NFOUND)=0
-        . S START=EDTT
-        . K TLIST
-        . F  S START=+$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START),-1) Q:(START=0)!(DONE)  D
-        .. S STOP=""
-        .. F  S STOP=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP),-1) Q:(STOP="")!(DONE)  D
-        ... S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
-        ... S OVERLAP=$$OVERLAP^PXRMINDX(START,SDATE,BDT,EDTT)
-        ... I OVERLAP="O" D
-        .... S DAS=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP,""))
-        .... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_START_U_SDATE
-        ... I FILENUM="55NVA" Q
-        ... I FILENUM=100 Q
-        ... I OVERLAP="L" S DONE=1 Q
-        .;Return up to NGET of the most recent entries.
-        . S NFOUND=0,TDATE=""
-        . F  S TDATE=$O(TLIST(TDATE)) Q:(TDATE="")!(NFOUND=NGET)  D
-        .. S TIND=0
-        .. F  S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET)  D
-        ... S NFOUND=NFOUND+1,^TMP($J,PLIST,DFN,NFOUND)=TLIST(TDATE,TIND)
-        Q
-        ;
-        ;================================================
-GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST)        ;Add to the patient list
-        ;for a regular file. Return the list in ^TMP($J,PLIST):
-        ;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^VALUE
-        N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST,GPLIST
-        N ICOND,IND,INVFD,IPLIST,NOCC,NFOUND,NGET
-        N SAVE,SSFIND,STATOK,STATUSA,TEMP,TGLIST,TPLIST
-        N UCIFS,USESTRT,VALUE,VSLIST
-        S TGLIST="GPLIST_PXRMINDL"
-        ;Determine if this is a finding with a start and stop date.
-        S SSFIND=$S(FILENUM=52:1,FILENUM[55:1,FILENUM=100:1,1:0)
-        S USESTRT=$S(SSFIND:$P(PFINDPA(0),U,15),1:0)
-        I FILENUM=100,USESTRT="" S USESTRT=1
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
-        S INVFD=$P(PFINDPA(0),U,16)
-        D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
-        D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        ;Ignore any negative occurrence counts, date reversal not allowed
-        ;in patient lists.
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
-        I SSFIND D FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,TGLIST)
-        I 'SSFIND D FPLIST(FILENUM,SNODE,ITEM,NGET,BDT,EDT,TGLIST)
-        S DFN=""
-        F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
-        . K GPLIST
-        . M GPLIST=^TMP($J,TGLIST,DFN)
-        . S (IND,NFOUND)=0
-        . K IPLIST
-        . F  S IND=$O(GPLIST(IND)) Q:(IND="")!(NFOUND=NOCC)  D
-        .. S TEMP=GPLIST(IND)
-        .. S DAS=$P(TEMP,U,1)
-        ..;If this a Lab finding attach the item to the DAS.
-        .. I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
-        ..;If this is a Mental Health finding attach the scale to DAS.
-        .. I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
-        .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
-        .. S VALUE=$G(FIEVD("VALUE"))
-        .. I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
-        ..;If there is a status list make sure the finding has a status on
-        ..;the list.
-        .. S STATOK=$S($D(STATUSA):$$STATUSOK^PXRMINDX(.STATUSA,.FIEVD),1:1)
-        .. I 'STATOK Q
-        .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
-        .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        .. I SAVE D
-        ... S NFOUND=NFOUND+1
-        ... S IPLIST(CONVAL,DFN,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE
-        . M ^TMP($J,PLIST)=IPLIST
-        K ^TMP($J,TGLIST)
-        Q
-        ;
+PXRMINDL ; SLC/PKR - List building routines. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;================================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;General patient list term evaluator.
+ ;Return the list in ^TMP($J,PLIST)
+ N ITEM,FILENUM,PFINDPA
+ N SSFIND,TEMP,TFINDING,TFINDPA
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D  Q
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
+ S ITEM=""
+ F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:ITEM=""  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
+ .. K PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)
+ Q
+ ;
+ ;================================================
+FPLIST(FILENUM,SNODE,ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list data for
+ ;regular files. Return the list in ^TMP($J,PLIST).
+ N DAS,DATE,DFN,DS,NFOUND
+ K ^TMP($J,PLIST)
+ I FILENUM=601.2 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q
+ S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ S DFN=0
+ F  S DFN=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN)) Q:DFN=""  D
+ . S NFOUND=0
+ . S DATE=DS
+ . F  S DATE=+$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC)  D
+ .. S NFOUND=NFOUND+1
+ .. S DAS=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE,""))
+ .. S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE
+ Q
+ ;
+ ;================================================
+FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,PLIST) ;Find patient list
+ ;data for a finding with a start and stop date.
+ ;Return the list in ^TMP($J,PLIST).
+ N DAS,DFN,DONE,EDTT,NFOUND,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
+ K ^TMP($J,PLIST)
+ S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ S DFN=0
+ F  S DFN=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN)) Q:DFN=""  D
+ . S (DONE,NFOUND)=0
+ . S START=EDTT
+ . K TLIST
+ . F  S START=+$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START),-1) Q:(START=0)!(DONE)  D
+ .. S STOP=""
+ .. F  S STOP=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP),-1) Q:(STOP="")!(DONE)  D
+ ... S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
+ ... S OVERLAP=$$OVERLAP^PXRMINDX(START,SDATE,BDT,EDTT)
+ ... I OVERLAP="O" D
+ .... S DAS=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,START,STOP,""))
+ .... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_START_U_SDATE
+ ... I FILENUM="55NVA" Q
+ ... I FILENUM=100 Q
+ ... I OVERLAP="L" S DONE=1 Q
+ .;Return up to NGET of the most recent entries.
+ . S NFOUND=0,TDATE=""
+ . F  S TDATE=$O(TLIST(TDATE)) Q:(TDATE="")!(NFOUND=NGET)  D
+ .. S TIND=0
+ .. F  S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET)  D
+ ... S NFOUND=NFOUND+1,^TMP($J,PLIST,DFN,NFOUND)=TLIST(TDATE,TIND)
+ Q
+ ;
+ ;================================================
+GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list
+ ;for a regular file. Return the list in ^TMP($J,PLIST):
+ ;^TMP($J,PLIST,T/F,DFN,ITEM,COUNT,FILENUM)=DAS^DATE^VALUE
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST,GPLIST
+ N ICOND,IND,INVFD,IPLIST,NOCC,NFOUND,NGET
+ N SAVE,SSFIND,STATOK,STATUSA,TEMP,TGLIST,TPLIST
+ N UCIFS,USESTRT,VALUE,VSLIST
+ S TGLIST="GPLIST_PXRMINDL"
+ ;Determine if this is a finding with a start and stop date.
+ S SSFIND=$S(FILENUM=52:1,FILENUM[55:1,FILENUM=100:1,1:0)
+ S USESTRT=$S(SSFIND:$P(PFINDPA(0),U,15),1:0)
+ I FILENUM=100,USESTRT="" S USESTRT=1
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ S INVFD=$P(PFINDPA(0),U,16)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
+ D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
+ I SSFIND D FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,TGLIST)
+ I 'SSFIND D FPLIST(FILENUM,SNODE,ITEM,NGET,BDT,EDT,TGLIST)
+ S DFN=""
+ F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
+ . K GPLIST
+ . M GPLIST=^TMP($J,TGLIST,DFN)
+ . S (IND,NFOUND)=0
+ . K IPLIST
+ . F  S IND=$O(GPLIST(IND)) Q:(IND="")!(NFOUND=NOCC)  D
+ .. S TEMP=GPLIST(IND)
+ .. S DAS=$P(TEMP,U,1)
+ ..;If this a Lab finding attach the item to the DAS.
+ .. I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
+ ..;If this is a Mental Health finding attach the scale to DAS.
+ .. I PFINDPA(0)["YTT(601" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
+ .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ .. S VALUE=$G(FIEVD("VALUE"))
+ .. I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
+ ..;If there is a status list make sure the finding has a status on
+ ..;the list.
+ .. S STATOK=$S($D(STATUSA):$$STATUSOK^PXRMINDX(.STATUSA,.FIEVD),1:1)
+ .. I 'STATOK Q
+ .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+ .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ .. I SAVE D
+ ... S NFOUND=NFOUND+1
+ ... S IPLIST(CONVAL,DFN,ITEM,NFOUND,FILENUM)=TEMP_U_VALUE
+ . M ^TMP($J,PLIST)=IPLIST
+ K ^TMP($J,TGLIST)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDX.m

@@ -1 @@
-PXRMINDX        ; SLC/PKR - Routines for utilizing the index. ;10/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;Code for patient findings.
-        ;================================================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;General finding evaluator.
-        N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM,NOINDEX
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
-        . S NOINDEX=1
-        E  S NOINDEX=0
-        S ITEM=""
-        F  S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:ITEM=""  D
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0  D
-        .. I NOINDEX S FIEVAL(FINDING)=0 Q
-        .. K FINDPA
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. K FIEVT
-        .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)
-        .. M FIEVAL(FINDING)=FIEVT
-        .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
-        Q
-        ;
-        ;================================================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;General term
-        ;evaluator.
-        N FIEVT,FILENUM,ITEM,NOINDEX,PFINDPA
-        N TFINDING,TFINDPA
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
-        . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
-        . S NOINDEX=1
-        E  S NOINDEX=0
-        S ITEM=""
-        F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
-        .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
-        .. K FIEVT,PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
-        .. M TFIEVAL(TFINDING)=FIEVT
-        .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
-        Q
-        ;
-        ;================================================================
-FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL)   ;
-        ;Evaluate regular patient findings.
-        N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,ICOND,IEN,IND,INVFD
-        N NFOUND,NGET,NOCC,NP
-        N SAVE,SDIR,SSFIND,STATOK,STATUSA,UCIFS,USESTRT,VSLIST
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
-        D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        S SDIR=$S(NOCC<0:+1,1:-1)
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        S NGET=$S(UCIFS:50,1:NOCC)
-        ;Determine if this is a finding with a start and stop date.
-        S SSFIND=$S(FILENUM=52:1,FILENUM["55":1,FILENUM=100:1,1:0)
-        S USESTRT=$S(SSFIND:$P(PFINDPA(0),U,15),1:0)
-        I FILENUM=100,USESTRT="" S USESTRT=1
-        ;Get the status list.
-        D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
-        I SSFIND D FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,.NFOUND,.FLIST)
-        I 'SSFIND D FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
-        I NFOUND=0 S FIEVAL=0 Q
-        S INVFD=$P(PFINDPA(0),U,16)
-        S NP=0
-        F IND=1:1:NFOUND Q:NP=NOCC  D
-        . S DAS=$P(FLIST(IND),U,1)
-        .;If this a Lab finding attach the item to the DAS.
-        . I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
-        .;If this is a Mental Health finding attach the scale to DAS.
-        . I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
-        . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
-        . I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
-        .;If there is a status list make sure the finding has one on the list.
-        . S STATOK=$S($D(STATUSA):$$STATUSOK(.STATUSA,.FIEVD),1:1)
-        . I 'STATOK Q
-        . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
-        . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        . I SAVE D
-        .. S NP=NP+1
-        .. S FIEVAL(NP)=CONVAL
-        .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
-        .. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1)
-        .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
-        .. M FIEVAL(NP)=FIEVD
-        .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD
-        ;
-        ;Save the finding result.
-        D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
-        S FIEVAL("FILE NUMBER")=FILENUM
-        Q
-        ;
-        ;================================================================
-FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST)    ;Find patient
-        ;data for regular files. FLIST is returned in date order, i.e.,
-        ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1.
-        I FILENUM=601.84 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
-        N DAS,DATE,DONE,EDTT
-        S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
-        S (DONE,NFOUND)=0
-        S DATE=$S(SDIR=+1:BDT-.000001,1:EDTT)
-        F  S DATE=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE),SDIR) Q:(DATE=0)!(DONE)  D
-        . I DATE<BDT,SDIR=-1 S DONE=1 Q
-        . I DATE>EDTT,SDIR=1 S DONE=1 Q
-        . S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,""))
-        . S NFOUND=NFOUND+1
-        . S FLIST(NFOUND)=DAS_U_DATE
-        . I NFOUND=NGET S DONE=1 Q
-        Q
-        ;
-        ;================================================================
-FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST)  ;Find
-        ;patient data for findings that have a start and stop date. FLIST
-        ;is returned in date order, i.e., FLIST(1) is the most recent.
-        N DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
-        S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
-        S (DONE,NFOUND)=0
-        S START=$S(SDIR=+1:0,1:EDTT)
-        F  S START=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR) Q:(START=0)!(DONE)!(START>EDTT)  D
-        . S STOP=""
-        . F  S STOP=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR) Q:(STOP="")!(DONE)  D
-        ..;Items that do not have a stop date are flagged by "U".
-        .. S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
-        .. S OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT)
-        .. I OVERLAP="O" D
-        ... S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,""))
-        ... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_SDATE
-        ..;Some orders and non-VA meds may not have a Stop Date so we have
-        ..;to check all entries.
-        .. I FILENUM="55NVA" Q
-        .. I FILENUM=100 Q
-        .. I OVERLAP="L",SDIR=-1 S DONE=1 Q
-        .. I OVERLAP="R",SDIR=1 S DONE=1 Q
-        ;Return up to NGET of the most recent/oldest entries.
-        S NFOUND=0,TDATE=""
-        F  S TDATE=$O(TLIST(TDATE),SDIR) Q:(TDATE="")!(NFOUND=NGET)  D
-        . S TIND=0
-        . F  S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET)  D
-        .. S NFOUND=NFOUND+1,FLIST(NFOUND)=TLIST(TDATE,TIND)
-        Q
-        ;
-        ;================================================================
-OVERLAP(START,STOP,BDT,EDT)     ;Determine if the date range defined by START and
-        ;STOP overlaps with the date range defined by BDT and EDT. The return
-        ;value "O" means they overlap, "L" means START, STOP is to the
-        ;left of BDT, EDT and "R" means it is to the right.
-        I EDT<START Q "R"
-        I STOP<BDT Q "L"
-        Q "O"
-        ;
-        ;================================================================
-STATUSOK(STATUSA,FIEVD) ;Return true if the status in FIEVD matches one in
-        ;the list in STATUSA.
-        I '$D(FIEVD("STATUS")) Q 1
-        N JND,OK
-        S OK=0
-        F JND=1:1:STATUSA(0) Q:OK  D
-        . I STATUSA(JND)="*" S OK=1 Q
-        . I STATUSA(JND)=FIEVD("STATUS") S OK=1 Q
-        Q OK
-        ;
+PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;Code for patient findings.
+ ;================================================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;General finding evaluator.
+ N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM,NOINDEX
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM)
+ . S NOINDEX=1
+ E  S NOINDEX=0
+ S ITEM=""
+ F  S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:ITEM=""  D
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0  D
+ .. I NOINDEX S FIEVAL(FINDING)=0 Q
+ .. K FINDPA
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. K FIEVT
+ .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)
+ .. M FIEVAL(FINDING)=FIEVT
+ .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
+ Q
+ ;
+ ;================================================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term
+ ;evaluator.
+ N FIEVT,FILENUM,ITEM,NOINDEX,PFINDPA
+ N TFINDING,TFINDPA
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D
+ . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM)
+ . S NOINDEX=1
+ E  S NOINDEX=0
+ S ITEM=""
+ F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
+ .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
+ .. K FIEVT,PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
+ .. M TFIEVAL(TFINDING)=FIEVT
+ .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
+ Q
+ ;
+ ;================================================================
+FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;
+ ;Evaluate regular patient findings.
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,ICOND,IEN,IND,INVFD
+ N NFOUND,NGET,NOCC,NP
+ N SAVE,SDIR,SSFIND,STATOK,STATUSA,UCIFS,USESTRT,VSLIST
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ S NGET=$S(UCIFS:"*",1:NOCC)
+ ;Determine if this is a finding with a start and stop date.
+ S SSFIND=$S(FILENUM=52:1,FILENUM["55":1,FILENUM=100:1,1:0)
+ S USESTRT=$S(SSFIND:$P(PFINDPA(0),U,15),1:0)
+ I FILENUM=100,USESTRT="" S USESTRT=1
+ ;Get the status list.
+ D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
+ I SSFIND D FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,.NFOUND,.FLIST)
+ I 'SSFIND D FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
+ I NFOUND=0 S FIEVAL=0 Q
+ S INVFD=$P(PFINDPA(0),U,16)
+ S NP=0
+ F IND=1:1:NFOUND Q:NP=NOCC  D
+ . S DAS=$P(FLIST(IND),U,1)
+ .;If this a Lab finding attach the item to the DAS.
+ . I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
+ .;If this is a Mental Health finding attach the scale to DAS.
+ . I PFINDPA(0)["YTT(601" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
+ . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ . I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
+ .;If there is a status list make sure the finding has one on the list.
+ . S STATOK=$S($D(STATUSA):$$STATUSOK(.STATUSA,.FIEVD),1:1)
+ . I 'STATOK Q
+ . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+ . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ . I SAVE D
+ .. S NP=NP+1
+ .. S FIEVAL(NP)=CONVAL
+ .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
+ .. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1)
+ .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
+ .. M FIEVAL(NP)=FIEVD
+ .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD
+ ;
+ ;Save the finding result.
+ D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
+ S FIEVAL("FILE NUMBER")=FILENUM
+ Q
+ ;
+ ;================================================================
+FPDAT(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient
+ ;data for regular files. FLIST is returned in date order, i.e.,
+ ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1.
+ I FILENUM=601.2 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
+ N DAS,DATE,DONE,EDTT
+ S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ S (DONE,NFOUND)=0
+ S DATE=$S(SDIR=+1:BDT-.000001,1:EDTT)
+ F  S DATE=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE),SDIR) Q:(DATE=0)!(DONE)  D
+ . I DATE<BDT,SDIR=-1 S DONE=1 Q
+ . I DATE>EDTT,SDIR=1 S DONE=1 Q
+ . S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,""))
+ . S NFOUND=NFOUND+1
+ . S FLIST(NFOUND)=DAS_U_DATE
+ . I NFOUND=NGET S DONE=1 Q
+ Q
+ ;
+ ;================================================================
+FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) ;Find
+ ;patient data for findings that have a start and stop date. FLIST
+ ;is returned in date order, i.e., FLIST(1) is the most recent.
+ N DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST
+ S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ S (DONE,NFOUND)=0
+ S START=$S(SDIR=+1:0,1:EDTT)
+ F  S START=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR) Q:(START=0)!(DONE)!(START>EDTT)  D
+ . S STOP=""
+ . F  S STOP=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR) Q:(STOP="")!(DONE)  D
+ ..;Items that do not have a stop date are flagged by "U".
+ .. S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP)
+ .. S OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT)
+ .. I OVERLAP="O" D
+ ... S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,""))
+ ... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_SDATE
+ ..;Some orders and non-VA meds may not have a Stop Date so we have
+ ..;to check all entries.
+ .. I FILENUM="55NVA" Q
+ .. I FILENUM=100 Q
+ .. I OVERLAP="L",SDIR=-1 S DONE=1 Q
+ .. I OVERLAP="R",SDIR=1 S DONE=1 Q
+ ;Return up to NGET of the most recent/oldest entries.
+ S NFOUND=0,TDATE=""
+ F  S TDATE=$O(TLIST(TDATE),SDIR) Q:(TDATE="")!(NFOUND=NGET)  D
+ . S TIND=0
+ . F  S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET)  D
+ .. S NFOUND=NFOUND+1,FLIST(NFOUND)=TLIST(TDATE,TIND)
+ Q
+ ;
+ ;================================================================
+OVERLAP(START,STOP,BDT,EDT) ;Determine if the date range defined by START and
+ ;STOP overlaps with the date range defined by BDT and EDT. The return
+ ;value "O" means they overlap, "L" means START, STOP is to the
+ ;left of BDT, EDT and "R" means it is to the right.
+ I EDT<START Q "R"
+ I STOP<BDT Q "L"
+ Q "O"
+ ;
+ ;================================================================
+STATUSOK(STATUSA,FIEVD) ;Return true if the status in FIEVD matches one in
+ ;the list in STATUSA.
+ I '$D(FIEVD("STATUS")) Q 1
+ N JND,OK
+ S OK=0
+ F JND=1:1:STATUSA(0) Q:OK  D
+ . I STATUSA(JND)="*" S OK=1 Q
+ . I STATUSA(JND)=FIEVD("STATUS") S OK=1 Q
+ Q OK
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMISE.m

@@ -1 @@
-PXRMISE ; SLC/PKR - Index size estimating routines. ;03/13/2006
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;========================================================
-EST     ;Driver for making index counts.
-        N BLOCKS,FUNCTION,GBL,GLIST,IND,NE,NL,NUMGBL,RTN
-        N SF,TASKIT,TBLOCKS,XMSUB
-        D SETDATA(.GBL,.GLIST,.NUMGBL,.RTN,.SF)
-        I +SF=-1 D ERRORMSG^PXRMISF(SF)  Q
-        S (NL,TBLOCKS)=0
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Start time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Size Estimate for ^PXRMINDX"
-        F IND=1:1:NUMGBL D
-        . S FUNCTION="S NE=$$"_RTN(GBL(IND))
-        . X FUNCTION
-        . S BLOCKS=NE*SF(GBL(IND))
-        . S BLOCKS=$FN(BLOCKS,"","")+1
-        . S TBLOCKS=TBLOCKS+BLOCKS
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Estimates for "_GLIST(IND)
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of entries: "_NE
-        . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of blocks: "_BLOCKS
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Total estimated blocks: "_TBLOCKS
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
-        S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="End time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S XMSUB="Size estimate for index global"
-        D SEND^PXRMMSG(XMSUB)
-        S ZTREQ="@"
-        Q
-        ;
-        ;===============================================================
-ESTTASK ;Task the index size estimation.
-        N DIR,DTOUT,DUOUT,MINDT,SDTIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        W !,"Queue the Clinical Reminders index size estimation."
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DTOUT)!$D(DUOUT) Q
-        S SDTIME=Y
-        K DIR
-        ;Put the task into the queue.
-        S ZTRTN="EST^PXRMISE"
-        S ZTDESC="Clinical Reminders index size estimation"
-        S ZTDTH=SDTIME
-        S ZTIO=""
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued."
-        Q
-        ;
-        ;===============================================================
-NEOR()  ;Return number of entries in OR.
-        ;DBIA #4180
-        Q $P(^OR(100,0),U,4)
-        ;
-        ;===============================================================
-NEPROB()        ;Return number of entries in PROBLEM LIST.
-        ;DBIA #3837
-        Q $P(^AUPNPROB(0),U,4)
-        ;
-        ;===============================================================
-NEPS()  ;Return number of entries in PS(55).
-        N ADD,DA,DA1,DFN,DRUG,IND,NE,SDATE,SOL,STARTD,TEMP
-        ;DBIA #4181
-        S (DFN,IND,NE)=0
-        F  S DFN=+$O(^PS(55,DFN)) Q:DFN=0  D
-        .;Process Unit Dose.
-        . S DA=0
-        . F  S DA=+$O(^PS(55,DFN,5,DA)) Q:DA=0  D
-        .. S TEMP=$G(^PS(55,DFN,5,DA,2))
-        .. S STARTD=$P(TEMP,U,2)
-        .. I STARTD="" Q
-        ..;If the order is purged then SDATE is 1.
-        .. S SDATE=$P(TEMP,U,4)
-        .. I SDATE=1 Q
-        .. S DA1=0
-        .. F  S DA1=+$O(^PS(55,DFN,5,DA,1,DA1)) Q:DA1=0  D
-        ... S DRUG=$P(^PS(55,DFN,5,DA,1,DA1,0),U,1)
-        ... I DRUG="" Q
-        ... S NE=NE+1
-        .;Process the IV mutiple.
-        . S DA=0
-        . F  S DA=+$O(^PS(55,DFN,"IV",DA)) Q:DA=0  D
-        .. S TEMP=$G(^PS(55,DFN,"IV",DA,0))
-        .. S STARTD=$P(TEMP,U,2)
-        .. I STARTD="" Q
-        .. S SDATE=$P(TEMP,U,3)
-        .. I SDATE=1 Q
-        ..;Process Additives
-        .. S DA1=0
-        .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"AD",DA1)) Q:DA1=0  D
-        ... S ADD=$P(^PS(55,DFN,"IV",DA,"AD",DA1,0),U,1)
-        ... I ADD="" Q
-        ... S DRUG=$P($G(^PS(52.6,ADD,0)),U,2)
-        ... I DRUG="" Q
-        ... S NE=NE+1
-        ..;Process Solutions
-        .. S DA1=0
-        .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"SOL",DA1)) Q:DA1=0  D
-        ... S SOL=$P(^PS(55,DFN,"IV",DA,"SOL",DA1,0),U,1)
-        ... I SOL="" Q
-        ... S DRUG=$P($G(^PS(52.7,SOL,0)),U,2)
-        ... I DRUG="" Q
-        ... S NE=NE+1
-        Q NE
-        ;
-        ;===============================================================
-NEPSRX()        ;Return number of entries in PSRX
-        N DA,DA1,DATE,DSUP,DFN,DRUG,NE,RDATE,TEMP
-        ;DBIA #4182
-        S (DA,NE)=0
-        F  S DA=+$O(^PSRX(DA)) Q:DA=0  D
-        . S TEMP=$G(^PSRX(DA,0))
-        . S DFN=$P(TEMP,U,2)
-        . I DFN="" Q
-        . S DRUG=$P(TEMP,U,6)
-        . I DRUG="" Q
-        . S DSUP=$P(TEMP,U,8)
-        . I DSUP="" Q
-        . S RDATE=+$P($G(^PSRX(DA,2)),U,13)
-        . I RDATE>0 S NE=NE+1
-        .;Process the refill mutiple.
-        . S DA1=0
-        . F  S DA1=+$O(^PSRX(DA,1,DA1)) Q:DA1=0  D
-        .. S TEMP=$G(^PSRX(DA,1,DA1,0))
-        .. S DSUP=+$P(TEMP,U,10)
-        .. S RDATE=+$P(TEMP,U,18)
-        .. I RDATE>0 S NE=NE+1
-        .;Process the partial fill multiple.
-        . S DA1=0
-        . F  S DA1=+$O(^PSRX(DA,"P",DA1)) Q:DA1=0  D
-        .. S TEMP=$G(^PSRX(DA,"P",DA1,0))
-        .. S DSUP=+$P(TEMP,U,10)
-        .. S RDATE=+$P(TEMP,U,19)
-        .. I RDATE>0 S NE=NE+1
-        Q NE
-        ;
-        ;===============================================================
-NEPTF() ;Return number of entries in PTF.
-        N D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS
-        ;DBIA #4177
-        S (DA,NE0,NE9)=0
-        F  S DA=+$O(^DGPT(DA)) Q:DA=0  D
-        . S TEMP0=$G(^DGPT(DA,0))
-        . S DFN=$P(TEMP0,U,1)
-        . I DFN="" Q
-        . S D1=0
-        . F  S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0  D
-        .. S TEMPS=$G(^DGPT(DA,"S",D1,0))
-        .. S DATE=$P(TEMPS,U,1)
-        .. I DATE="" Q
-        .. F JND=8,9,10,11,12 D
-        ... S ICD0=$P(TEMPS,U,JND)
-        ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
-        .;
-        . S D1=0
-        . F  S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0  D
-        .. S TEMPP=$G(^DGPT(DA,"P",D1,0))
-        .. S DATE=$P(TEMPP,U,1)
-        .. I DATE="" Q
-        .. F JND=5,6,7,8,9 D
-        ... S ICD0=$P(TEMPP,U,JND)
-        ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
-        .;
-        .;Discharge ICD9 codes
-        . I $D(^DGPT(DA,70)) D
-        .. S TEMP70=$G(^DGPT(DA,70))
-        .. F JND=10,11,16,17,18,19,20,21,22,23,24 D
-        ... S ICD9=$P(TEMP70,U,JND)
-        ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
-        .;
-        .;Movement ICD9 codes
-        . I '$D(^DGPT(DA,"M")) Q
-        . S D1=0
-        . F  S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0  D
-        .. S TEMPS=$G(^DGPT(DA,"M",D1,0))
-        .. S DATE=$P(TEMPS,U,10)
-        .. I DATE="" Q
-        .. F JND=5,6,7,8,9,11,12,13,14,15 D
-        ... S ICD9=$P(TEMPS,U,JND)
-        ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
-        Q NE0+NE9
-        ;
-        ;===============================================================
-NERAD() ;Return number of entries in RAD/NUC MED PATIENT.
-        N IEN,NE
-        ;DBIA #4183
-        S (IEN,NE)=0
-        F  S IEN=$O(^RADPT(IEN)) Q:+IEN=0  S NE=NE+$P($G(^RADPT(IEN,"DT",0)),U,4)
-        Q NE
-        ;
-        ;===============================================================
-NEVCPT()        ;Return number of entries in V CPT.
-        ;DBIA #4176
-        Q $P(^AUPNVCPT(0),U,4)
-        ;
-        ;===============================================================
-NEVHF() ;Return number of entries in V HEALTH FACTORS.
-        ;DBIA #4176
-        Q $P(^AUPNVHF(0),U,4)
-        ;
-        ;===============================================================
-NEVIMM()        ;Return number of entries in V IMMUNIZATION
-        ;DBIA #4176
-        Q $P(^AUPNVIMM(0),U,4)
-        ;
-        ;===============================================================
-NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT
-        ;DBIA #4178
-        Q $P(^GMR(120.5,0),U,4)
-        ;
-        ;===============================================================
-NEVPED()        ;Return number of entries in V PATIENT ED.
-        ;DBIA #4176
-        Q $P(^AUPNVPED(0),U,4)
-        ;
-        ;===============================================================
-NEVPOV()        ;Return number of entries in V POV.
-        ;DBIA #4176
-        Q $P(^AUPNVPOV(0),U,4)
-        ;
-        ;===============================================================
-NEVSK() ;Return number of entries in V SKIN TEST.
-        ;DBIA #4176
-        Q $P(^AUPNVSK(0),U,4)
-        ;
-        ;===============================================================
-NEVXAM()        ;Return number of entries in V EXAM.
-        ;DBIA #4176
-        Q $P(^AUPNVXAM(0),U,4)
-        ;
-        ;===============================================================
-NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT
-        N DATE,DFN,NE,TEST
-        ;DBIA #4184
-        S (DFN,NE)=0
-        F  S DFN=$O(^YTD(601.2,DFN)) Q:+DFN=0  D
-        . S TEST=0
-        . F  S TEST=$O(^YTD(601.2,DFN,1,TEST)) Q:+TEST=0  D
-        .. S DATE=0
-        .. F  S DATE=$O(^YTD(601.2,DFN,1,TEST,1,DATE)) Q:+DATE=0  S NE=NE+1
-        Q NE
-        ;
-        ;===============================================================
-SETDATA(GBL,GLIST,NUMGBL,RTN,SF)        ;
-        S NUMGBL=16
-        S GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
-        S GLIST(2)="MENTAL HEALTH",GBL(2)=601.2
-        S GLIST(3)="ORDER",GBL(3)=100
-        S GLIST(4)="PTF",GBL(4)=45
-        S GLIST(5)="PHARMACY PATIENT",GBL(5)=55
-        S GLIST(6)="PRESCRIPTION",GBL(6)=52
-        S GLIST(7)="PROBLEM LIST",GBL(7)=9000011
-        S GLIST(8)="RADIOLOGY",GBL(8)=70
-        S GLIST(9)="V CPT",GBL(9)=9000010.18
-        S GLIST(10)="V EXAM",GBL(10)=9000010.13
-        S GLIST(11)="V HEALTH FACTORS",GBL(11)=9000010.23
-        S GLIST(12)="V IMMUNIZATION",GBL(12)=9000010.11
-        S GLIST(13)="V PATIENT ED",GBL(13)=9000010.16
-        S GLIST(14)="V POV",GBL(14)=9000010.07
-        S GLIST(15)="V SKIN TEST",GBL(15)=9000010.12
-        S GLIST(16)="VITAL MEASUREMENT",GBL(16)=120.5
-        S RTN(45)="NEPTF^PXRMISE"
-        S RTN(52)="NEPSRX^PXRMISE"
-        S RTN(55)="NEPS^PXRMISE"
-        S RTN(63)="NELR^PXRMLABS"
-        S RTN(70)="NERAD^PXRMISE"
-        S RTN(100)="NEOR^PXRMISE"
-        S RTN(120.5)="NEVIT^PXRMISE"
-        S RTN(601.2)="NEYTD^PXRMISE"
-        S RTN(9000011)="NEPROB^PXRMISE"
-        S RTN(9000010.07)="NEVPOV^PXRMISE"
-        S RTN(9000010.11)="NEVIMM^PXRMISE"
-        S RTN(9000010.12)="NEVSK^PXRMISE"
-        S RTN(9000010.13)="NEVXAM^PXRMISE"
-        S RTN(9000010.16)="NEVPED^PXRMISE"
-        S RTN(9000010.18)="NEVCPT^PXRMISE"
-        S RTN(9000010.23)="NEVHF^PXRMISE"
-        D LSF^PXRMISF(.SF)
-        Q
-        ;
+PXRMISE ; SLC/PKR - Index size estimating routines. ;01/12/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;========================================================
+EST ;Driver for making index counts.
+ N BLOCKS,FUNCTION,GBL,GLIST,IND,NE,NL,NUMGBL,RTN
+ N SF,TASKIT,TBLOCKS,XMSUB
+ D SETDATA(.GBL,.GLIST,.NUMGBL,.RTN,.SF)
+ I +SF=-1 D ERRORMSG^PXRMISF(SF)  Q
+ S (NL,TBLOCKS)=0
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Start time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Size Estimate for ^PXRMINDX"
+ F IND=1:1:NUMGBL D
+ . S FUNCTION="S NE=$$"_RTN(GBL(IND))
+ . X FUNCTION
+ . S BLOCKS=NE*SF(GBL(IND))
+ . S BLOCKS=$FN(BLOCKS,"","")+1
+ . S TBLOCKS=TBLOCKS+BLOCKS
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Estimates for "_GLIST(IND)
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of entries: "_NE
+ . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of blocks: "_BLOCKS
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Total estimated blocks: "_TBLOCKS
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=""
+ S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="End time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S XMSUB="Size estimate for index global"
+ D SEND^PXRMMSG(XMSUB)
+ S ZTREQ="@"
+ Q
+ ;
+ ;===============================================================
+ESTTASK ;Task the index size estimation.
+ N DIR,DTOUT,DUOUT,MINDT,SDTIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ W !,"Queue the Clinical Reminders index size estimation."
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DTOUT)!$D(DUOUT) Q
+ S SDTIME=Y
+ K DIR
+ ;Put the task into the queue.
+ S ZTRTN="EST^PXRMISE"
+ S ZTDESC="Clinical Reminders index size estimation"
+ S ZTDTH=SDTIME
+ S ZTIO=""
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued."
+ Q
+ ;
+ ;===============================================================
+NEOR() ;Return number of entries in OR.
+ ;DBIA #4180
+ Q $P(^OR(100,0),U,4)
+ ;
+ ;===============================================================
+NEPROB() ;Return number of entries in PROBLEM LIST.
+ ;DBIA #3837
+ Q $P(^AUPNPROB(0),U,4)
+ ;
+ ;===============================================================
+NEPS() ;Return number of entries in PS(55).
+ N ADD,DA,DA1,DFN,DRUG,IND,NE,SDATE,SOL,STARTD,TEMP
+ ;DBIA #4181
+ S (DFN,IND,NE)=0
+ F  S DFN=+$O(^PS(55,DFN)) Q:DFN=0  D
+ .;Process Unit Dose.
+ . S DA=0
+ . F  S DA=+$O(^PS(55,DFN,5,DA)) Q:DA=0  D
+ .. S TEMP=$G(^PS(55,DFN,5,DA,2))
+ .. S STARTD=$P(TEMP,U,2)
+ .. I STARTD="" Q
+ ..;If the order is purged then SDATE is 1.
+ .. S SDATE=$P(TEMP,U,4)
+ .. I SDATE=1 Q
+ .. S DA1=0
+ .. F  S DA1=+$O(^PS(55,DFN,5,DA,1,DA1)) Q:DA1=0  D
+ ... S DRUG=$P(^PS(55,DFN,5,DA,1,DA1,0),U,1)
+ ... I DRUG="" Q
+ ... S NE=NE+1
+ .;Process the IV mutiple.
+ . S DA=0
+ . F  S DA=+$O(^PS(55,DFN,"IV",DA)) Q:DA=0  D
+ .. S TEMP=$G(^PS(55,DFN,"IV",DA,0))
+ .. S STARTD=$P(TEMP,U,2)
+ .. I STARTD="" Q
+ .. S SDATE=$P(TEMP,U,3)
+ .. I SDATE=1 Q
+ ..;Process Additives
+ .. S DA1=0
+ .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"AD",DA1)) Q:DA1=0  D
+ ... S ADD=$P(^PS(55,DFN,"IV",DA,"AD",DA1,0),U,1)
+ ... I ADD="" Q
+ ... S DRUG=$P($G(^PS(52.6,ADD,0)),U,2)
+ ... I DRUG="" Q
+ ... S NE=NE+1
+ ..;Process Solutions
+ .. S DA1=0
+ .. F  S DA1=+$O(^PS(55,DFN,"IV",DA,"SOL",DA1)) Q:DA1=0  D
+ ... S SOL=$P(^PS(55,DFN,"IV",DA,"SOL",DA1,0),U,1)
+ ... I SOL="" Q
+ ... S DRUG=$P($G(^PS(52.7,SOL,0)),U,2)
+ ... I DRUG="" Q
+ ... S NE=NE+1
+ Q NE
+ ;
+ ;===============================================================
+NEPSRX() ;Return number of entries in PSRX
+ N DA,DA1,DATE,DSUP,DFN,DRUG,NE,RDATE,TEMP
+ ;DBIA #4182
+ S (DA,NE)=0
+ F  S DA=+$O(^PSRX(DA)) Q:DA=0  D
+ . S TEMP=$G(^PSRX(DA,0))
+ . S DFN=$P(TEMP,U,2)
+ . I DFN="" Q
+ . S DRUG=$P(TEMP,U,6)
+ . I DRUG="" Q
+ . S DSUP=$P(TEMP,U,8)
+ . I DSUP="" Q
+ . S RDATE=+$P($G(^PSRX(DA,2)),U,13)
+ . I RDATE>0 S NE=NE+1
+ .;Process the refill mutiple.
+ . S DA1=0
+ . F  S DA1=+$O(^PSRX(DA,1,DA1)) Q:DA1=0  D
+ .. S TEMP=$G(^PSRX(DA,1,DA1,0))
+ .. S DSUP=+$P(TEMP,U,10)
+ .. S RDATE=+$P(TEMP,U,18)
+ .. I RDATE>0 S NE=NE+1
+ .;Process the partial fill multiple.
+ . S DA1=0
+ . F  S DA1=+$O(^PSRX(DA,"P",DA1)) Q:DA1=0  D
+ .. S TEMP=$G(^PSRX(DA,"P",DA1,0))
+ .. S DSUP=+$P(TEMP,U,10)
+ .. S RDATE=+$P(TEMP,U,19)
+ .. I RDATE>0 S NE=NE+1
+ Q NE
+ ;
+ ;===============================================================
+NEPTF() ;Return number of entries in PTF.
+ N D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS
+ ;DBIA #4177
+ S (DA,NE0,NE9)=0
+ F  S DA=+$O(^DGPT(DA)) Q:DA=0  D
+ . S TEMP0=$G(^DGPT(DA,0))
+ . S DFN=$P(TEMP0,U,1)
+ . I DFN="" Q
+ . S D1=0
+ . F  S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0  D
+ .. S TEMPS=$G(^DGPT(DA,"S",D1,0))
+ .. S DATE=$P(TEMPS,U,1)
+ .. I DATE="" Q
+ .. F JND=8,9,10,11,12 D
+ ... S ICD0=$P(TEMPS,U,JND)
+ ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
+ .;
+ . S D1=0
+ . F  S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0  D
+ .. S TEMPP=$G(^DGPT(DA,"P",D1,0))
+ .. S DATE=$P(TEMPP,U,1)
+ .. I DATE="" Q
+ .. F JND=5,6,7,8,9 D
+ ... S ICD0=$P(TEMPP,U,JND)
+ ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1
+ .;
+ .;Discharge ICD9 codes
+ . I $D(^DGPT(DA,70)) D
+ .. S TEMP70=$G(^DGPT(DA,70))
+ .. F JND=10,11,16,17,18,19,20,21,22,23,24 D
+ ... S ICD9=$P(TEMP70,U,JND)
+ ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
+ .;
+ .;Movement ICD9 codes
+ . I '$D(^DGPT(DA,"M")) Q
+ . S D1=0
+ . F  S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0  D
+ .. S TEMPS=$G(^DGPT(DA,"M",D1,0))
+ .. S DATE=$P(TEMPS,U,10)
+ .. I DATE="" Q
+ .. F JND=5,6,7,8,9,11,12,13,14,15 D
+ ... S ICD9=$P(TEMPS,U,JND)
+ ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1
+ Q NE0+NE9
+ ;
+ ;===============================================================
+NERAD() ;Return number of entries in RAD/NUC MED PATIENT.
+ N IEN,NE
+ ;DBIA #4183
+ S (IEN,NE)=0
+ F  S IEN=$O(^RADPT(IEN)) Q:+IEN=0  S NE=NE+$P($G(^RADPT(IEN,"DT",0)),U,4)
+ Q NE
+ ;
+ ;===============================================================
+NEVCPT() ;Return number of entries in V CPT.
+ ;DBIA #4176
+ Q $P(^AUPNVCPT(0),U,4)
+ ;
+ ;===============================================================
+NEVHF() ;Return number of entries in V HEALTH FACTORS.
+ ;DBIA #4176
+ Q $P(^AUPNVHF(0),U,4)
+ ;
+ ;===============================================================
+NEVIMM() ;Return number of entries in V IMMUNIZATION
+ ;DBIA #4176
+ Q $P(^AUPNVIMM(0),U,4)
+ ;
+ ;===============================================================
+NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT
+ ;DBIA #4178
+ Q $P(^GMR(120.5,0),U,4)
+ ;
+ ;===============================================================
+NEVPED() ;Return number of entries in V PATIENT ED.
+ ;DBIA #4176
+ Q $P(^AUPNVPED(0),U,4)
+ ;
+ ;===============================================================
+NEVPOV() ;Return number of entries in V POV.
+ ;DBIA #4176
+ Q $P(^AUPNVPOV(0),U,4)
+ ;
+ ;===============================================================
+NEVSK() ;Return number of entries in V SKIN TEST.
+ ;DBIA #4176
+ Q $P(^AUPNVSK(0),U,4)
+ ;
+ ;===============================================================
+NEVXAM() ;Return number of entries in V EXAM.
+ ;DBIA #4176
+ Q $P(^AUPNVXAM(0),U,4)
+ ;
+ ;===============================================================
+NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT
+ N DATE,DFN,NE,TEST
+ ;DBIA #4184
+ S (DFN,NE)=0
+ F  S DFN=$O(^YTD(601.2,DFN)) Q:+DFN=0  D
+ . S TEST=0
+ . F  S TEST=$O(^YTD(601.2,DFN,1,TEST)) Q:+TEST=0  D
+ .. S DATE=0
+ .. F  S DATE=$O(^YTD(601.2,DFN,1,TEST,1,DATE)) Q:+DATE=0  S NE=NE+1
+ Q NE
+ ;
+ ;===============================================================
+SETDATA(GBL,GLIST,NUMGBL,RTN,SF) ;
+ S NUMGBL=16
+ S GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
+ S GLIST(2)="MENTAL HEALTH",GBL(2)=601.2
+ S GLIST(3)="ORDER",GBL(3)=100
+ S GLIST(4)="PTF",GBL(4)=45
+ S GLIST(5)="PHARMACY PATIENT",GBL(5)=55
+ S GLIST(6)="PRESCRIPTION",GBL(6)=52
+ S GLIST(7)="PROBLEM LIST",GBL(7)=9000011
+ S GLIST(8)="RADIOLOGY",GBL(8)=70
+ S GLIST(9)="V CPT",GBL(9)=9000010.18
+ S GLIST(10)="V EXAM",GBL(10)=9000010.13
+ S GLIST(11)="V HEALTH FACTORS",GBL(11)=9000010.23
+ S GLIST(12)="V IMMUNIZATION",GBL(12)=9000010.11
+ S GLIST(13)="V PATIENT ED",GBL(13)=9000010.16
+ S GLIST(14)="V POV",GBL(14)=9000010.07
+ S GLIST(15)="V SKIN TEST",GBL(15)=9000010.12
+ S GLIST(16)="VITAL MEASUREMENT",GBL(16)=120.5
+ S RTN(45)="NEPTF^PXRMISE"
+ S RTN(52)="NEPSRX^PXRMISE"
+ S RTN(55)="NEPS^PXRMISE"
+ S RTN(63)="NELR^PXRMLABS"
+ S RTN(70)="NERAD^PXRMISE"
+ S RTN(100)="NEOR^PXRMISE"
+ S RTN(120.5)="NEVIT^PXRMISE"
+ S RTN(601.2)="NEYTD^PXRMISE"
+ S RTN(9000011)="NEPROB^PXRMISE"
+ S RTN(9000010.07)="NEVPOV^PXRMISE"
+ S RTN(9000010.11)="NEVIMM^PXRMISE"
+ S RTN(9000010.12)="NEVSK^PXRMISE"
+ S RTN(9000010.13)="NEVXAM^PXRMISE"
+ S RTN(9000010.16)="NEVPED^PXRMISE"
+ S RTN(9000010.18)="NEVCPT^PXRMISE"
+ S RTN(9000010.23)="NEVHF^PXRMISE"
+ D LSF^PXRMISF(.SF)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m

@@ -1 @@
-PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;11/02/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Display list creation documentation.
-        ;===========================================================
-DCDOC   ;Display creation documentation.
-        N IND,LISTIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        ;PXRMDONE is newed in PXRMLPU
-        S IND="",PXRMDONE=0
-        F  S IND=$O(VALMY(IND)) Q:(IND="")!(PXRMDONE)  D
-        . S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
-        . D EN^PXRMLCD(LISTIEN)
-        S VALMBCK="R"
-        Q
-        ;
-        ;===========================================================
-EN(LISTIEN)     ;
-        N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
-        K ^TMP("PXRMLCD",$J)
-        I $D(^PXRMXP(810.5,LISTIEN,200)) D
-        . M ^TMP("PXRMLCD",$J)=^PXRMXP(810.5,LISTIEN,200)
-        . S VALMCNT=$P(^PXRMXP(810.5,LISTIEN,200,0),U,4)
-        I '$D(^PXRMXP(810.5,LISTIEN,200)) D
-        . S ^TMP("PXRMLCD",$J,1,0)="No documentation is available."
-        . S VALMCNT=1
-        D EN^VALM("PXRM PATIENT LIST CREATION DOC")
-        Q
-        ;
-        ;===========================================================
-EXIT    ;Exit code
-        K ^TMP("PXRMLCD",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="R"
-        Q
-        ;
-        ;===========================================================
-HDR     ; Header code
-        S VALMHDR(1)="Documentation for creation of patient list:"
-        S VALMHDR(2)=" "_$P(^PXRMXP(810.5,LISTIEN,0),U,1)
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-        ;===========================================================
-HELP    ;Help code
-        S X="?" D DISP^XQORM1 W !!
-        Q
-        ;
+PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;06/30/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Display list creation documentation.
+ ;===========================================================
+DCDOC ;Display creation documentation.
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPU
+ S IND="",PXRMDONE=0
+ F  S IND=$O(VALMY(IND)) Q:(IND="")!(PXRMDONE)  D
+ . S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
+ . D EN^PXRMLCD(LISTIEN)
+ S VALMBCK="R"
+ Q
+ ;
+ ;===========================================================
+EN(LISTIEN) ;
+ N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+ K ^TMP("PXRMLCD",$J)
+ I $D(^PXRMXP(810.5,LISTIEN,200)) D
+ . M ^TMP("PXRMLCD",$J)=^PXRMXP(810.5,LISTIEN,200)
+ . S VALMCNT=$P(^PXRMXP(810.5,LISTIEN,200,0),U,4)
+ I '$D(^PXRMXP(810.5,LISTIEN,200)) D
+ . S ^TMP("PXRMLCD",$J,1,0)="No documentation is available."
+ . S VALMCNT=1
+ D EN^VALM("PXRM PATIENT LIST CREATION DOC")
+ Q
+ ;
+ ;===========================================================
+EXIT ;Exit code
+ K ^TMP("PXRMLCD",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="R"
+ Q
+ ;
+ ;===========================================================
+HDR ; Header code
+ S VALMHDR(1)="Documentation for creation of patient list "_$P(^PXRMXP(810.5,LISTIEN,0),U,1)
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+ ;===========================================================
+HELP ;Help code
+ S X="?" D DISP^XQORM1 W !!
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m

@@ -1 @@
-PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 10/18/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRM PATIENT LIST CREATE protocol
-        ;
-START   N BEG,DUOUT,DTOUT,END,LIT,PXRMDPAT,PXRMLIST,PXRMNODE,PXRMRULE,PXRMTPAT
-        N TEXT
-        ;Initialise
-        K ^TMP("PXRMLCR",$J)
-        ;Node for ^TMP lists created in PXRMRULE
-        S PXRMNODE="PXRMRULE",LIT="Patient List"
-        ;Reset screen mode
-        W IORESET
-        ;Set prompt text
-        S TEXT="Select PATIENT LIST name: "
-        ;Select Patient List
-LIST    D PLIST(.PXRMLIST,TEXT,"") I $D(DUOUT)!$D(DTOUT) D  Q
-        . I $G(PXRMLIST)="" Q
-        . I $P($G(^PXRMXP(810.5,PXRMLIST,0)),U,4)'="" Q
-        . S DA=PXRMLIST,DIK="^PXRMXP(810.5," D ^DIK
-        ;
-SECURE  ;option to secure the list
-        K PATCREAT
-        I $D(PATCREAT)=0 S PATCREAT="N" D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2) Q:$D(DTOUT)  G:$D(DUOUT) START
-        ;
-PURGE   ;Option to purge the list
-        K PLISTPUG
-        S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) Q:$D(DTOUT)  G:$D(DUOUT) SECURE
-        ;Select rule set.
-RULE    D LRULE(.PXRMRULE) Q:$D(DTOUT)  G:$D(DUOUT) LIST
-        ;Select Date Range
-DATE    D DATES^PXRMEUT(.BEG,.END,LIT) Q:$D(DTOUT)  G:$D(DUOUT) RULE
-        ;
-        ;Ask whether to include deceased and test patients.
-DPAT    S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list")
-        Q:$D(DTOUT)  G:$D(DUOUT) DATE
-TPAT    S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
-        Q:$D(DTOUT)  G:$D(DUOUT) DPAT
-        I $G(PXRMDEBG) D RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) Q
-        ;Build patient list in background
-        N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
-        S ZTDESC="CREATE PATIENT LIST"
-        S ZTRTN="RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)"
-        S ZTSAVE("BEG")=""
-        S ZTSAVE("END")=""
-        S ZTSAVE("PATCREAT")=""
-        S ZTSAVE("PXRMDPAT")=""
-        S ZTSAVE("PXRMLIST")=""
-        S ZTSAVE("PXRMNODE")=""
-        S ZTSAVE("PXRMRULE")=""
-        S ZTSAVE("PXRMTPAT")=""
-        S ZTSAVE("PLISTPUG")=""
-        S ZTIO=""
-        ;
-        ;Select and verify start date/time for task
-        N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        W !,"Queue the "_ZTDESC_" for "_$P($G(^PXRMXP(810.5,PXRMLIST,0)),U)_": "
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DTOUT)!$D(DUOUT) Q
-        S SDTIME=Y
-        ;
-        ;Put the task into the queue.
-        S ZTDTH=SDTIME
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued." H 2
-EXIT    Q
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
-        .S HTEXT(2)="use a different patient list name."
-        ;
-        I CALL=2 D
-        .S HTEXT(1)="Enter 'Y' to make the list private or 'N' to make it public."
-        .S HTEXT(2)="You can give other users access to your private lists in the Patient List Menu screens."
-        ;
-        I CALL=3 D
-        .S HTEXT(1)="Enter Y to save the patient to a Reminder Patient List. Enter N to not save the output."
-        ;
-        I CALL=4 D
-        .S HTEXT(1)="Enter Y to turn on debug output."
-        .S HTEXT(2)="The debug output will send a series of MailMan messages to the requestor of the report"
-        .S HTEXT(3)="-**WARNING**- the reminder report will take longer to run if you turn on this option!"
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-PLIST(LIST,TEXT,IENO)   ;Select Patient List
-        N X,Y,DIC,DLAYGO
-PL1     S DIC=810.5,DLAYGO=DIC,DIC(0)="QAEMZL"
-        S DIC("A")=TEXT
-        S DIC("S")="I $P($G(^(100)),U)'=""N"""
-        ;If this is a new entry save the creator, make the TYPE public and
-        ;CLASS local.
-        S DIC("DR")=".07///`"_DUZ_";.08///PUB;100///L"
-        W !
-        D ^DIC
-        I X="" W !,"A patient list name must be entered" G PL1
-        I X=(U_U) S DTOUT=1
-        I Y=-1 S DUOUT=1
-        I $D(DTOUT)!$D(DUOUT) Q
-        ;
-        ;I copy mode dissallow copy to same list
-        I IENO=$P(Y,U) W !,"A patient list cannot be copied to itself." G PL1
-        ;
-        I ($P(Y,U,3)=1) S LIST=$P(Y,U) Q
-        ;Check if OK to overwrite
-        N OWRITE
-        S OWRITE=$$ASKYN^PXRMEUT("N","Okay to overwite "_$P(Y,U,2),"PXRMLCR",1)
-        Q:$D(DTOUT)  G:$D(DUOUT)!('OWRITE) PL1
-        S OWRITE=$$LDELOK^PXRMEUT($P(Y,U,1))
-        I 'OWRITE D  G PL1
-        . W !,"In order to overwrite a list you must be the creator or a Reminder Manager!"
-        ;Return list ien
-        S LIST=$P(Y,U)
-        Q
-        ;
-LRULE(RULE)     ;Select List Rule
-        N X,Y,DIC
-LR1     S DIC=810.4,DIC(0)="QAEMZ"
-        S DIC("A")="Select LIST RULE SET: "
-        ;Only allow rule sets with components
-        S DIC("S")="I $P(^(0),U,3)=3"
-        W !
-        D ^DIC
-        I X="" W !,"A list rule set name must be entered" G LR1
-        I X=(U_U) S DTOUT=1
-        I Y=-1 S DUOUT=1
-        I $D(DTOUT)!$D(DUOUT) Q
-        ;Return rule ien
-        S RULE=$P(Y,U)
-        ;Check that rule set is valid
-        N ERROR,LR,LRTYPE,NL,OP,SEQ,SUB,TEMP,TEXT
-        S SUB=$O(^PXRM(810.4,RULE,30,0))
-        I SUB="" W !,"Rule set has no component rules" G LR1
-        S (ERROR,SUB)=0,NL=1
-        F  S SUB=$O(^PXRM(810.4,RULE,30,SUB)) Q:'SUB  D  Q:ERROR
-        .S TEMP=$G(^PXRM(810.4,RULE,30,SUB,0))
-        .S SEQ=$P(TEMP,U,1),LR=$P(TEMP,U,2),OP=$P(TEMP,U,3)
-        .I SEQ="" S NL=NL+1,TEXT(NL)=" Sequence is missing.",ERROR=1
-        .I LR="" S NL=NL+1,TEXT(NL)=" List rule is missing.",ERROR=1
-        .I OP="" S NL=NL+1,TEXT(NL)=" Operation is missing.",ERROR=1
-        .;The Insert operation can only be used with finding rules.
-        .I OP="F",LR'="" D
-        ..S LRTYPE=$P(^PXRM(810.4,LR,0),U,3)
-        ..I LRTYPE'=1 S NL=NL+1,TEXT(NL)=" Insert operation can only be used with finding rules.",ERROR=1
-        I ERROR D  G LR1
-        .S TEXT(1)="The rule set is incomplete or incorrect:"
-        .D EN^DDIOL(.TEXT)
-        Q
-        ;
-        ;Build list and clear ^TMP files
-RUN(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)       ;
-        ;Process rule set and update final patient list
-        D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT,"")
-        ;Clear ^TMP lists created for rule
-        D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
-        Q
-        ;
-REMOVE(IEN)     ;
-        S $P(^PXRM(810.4,IEN,0),U,10)=""
-        Q "@1"
-        ;
+PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ; Called from PXRM PATIENT LIST CREATE protocol
+ ;
+START N BEG,DUOUT,DTOUT,END,LIT,PXRMDPAT,PXRMLIST,PXRMNODE,PXRMRULE,PXRMTPAT
+ N TEXT
+ ;Initialise
+ K ^TMP("PXRMLCR",$J)
+ ;Node for ^TMP lists created in PXRMRULE
+ S PXRMNODE="PXRMRULE",LIT="Patient List"
+ ;Reset screen mode
+ W IORESET
+ ;Set prompt text
+ S TEXT="Select PATIENT LIST name: "
+ ;Select Patient List
+LIST D PLIST(.PXRMLIST,TEXT,"") I $D(DUOUT)!$D(DTOUT) D  Q
+ . I $G(PXRMLIST)="" Q
+ . I $P($G(^PXRMXP(810.5,PXRMLIST,0)),U,4)'="" Q
+ . S DA=PXRMLIST,DIK="^PXRMXP(810.5," D ^DIK
+ ;
+SECURE ;option to secure the list
+ K PATCREAT
+ I $D(PATCREAT)=0 S PATCREAT="N" D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2) Q:$D(DTOUT)  G:$D(DUOUT) START
+ ;
+PURGE ;Option to purge the list
+ K PLISTPUG
+ S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) Q:$D(DTOUT)  G:$D(DUOUT) SECURE
+ ;Select rule set.
+RULE D LRULE(.PXRMRULE) Q:$D(DTOUT)  G:$D(DUOUT) LIST
+ ;Select Date Range
+DATE D DATES^PXRMEUT(.BEG,.END,LIT) Q:$D(DTOUT)  G:$D(DUOUT) RULE
+ ;
+ ;Ask whether to include deceased and test patients.
+DPAT S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list")
+ Q:$D(DTOUT)  G:$D(DUOUT) DATE
+TPAT S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
+ Q:$D(DTOUT)  G:$D(DUOUT) DPAT
+ ;Build patient list in background
+ N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+ S ZTDESC="CREATE PATIENT LIST"
+ S ZTRTN="RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)"
+ S ZTSAVE("BEG")=""
+ S ZTSAVE("END")=""
+ S ZTSAVE("PATCREAT")=""
+ S ZTSAVE("PXRMDPAT")=""
+ S ZTSAVE("PXRMLIST")=""
+ S ZTSAVE("PXRMNODE")=""
+ S ZTSAVE("PXRMRULE")=""
+ S ZTSAVE("PXRMTPAT")=""
+ S ZTSAVE("PLISTPUG")=""
+ S ZTIO=""
+ ;
+ ;Select and verify start date/time for task
+ N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ W !,"Queue the "_ZTDESC_" for "_$P($G(^PXRMXP(810.5,PXRMLIST,0)),U)_": "
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DTOUT)!$D(DUOUT) Q
+ S SDTIME=Y
+ ;
+ ;Put the task into the queue.
+ S ZTDTH=SDTIME
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued." H 2
+EXIT Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
+ .S HTEXT(2)="use a different patient list name."
+ ;
+ I CALL=2 D
+ .S HTEXT(1)="Enter 'Y' to make the list private or 'N' to make it public."
+ .S HTEXT(2)="You can give other users access to your private lists in the Patient List Menu screens."
+ ;
+ I CALL=3 D
+ .S HTEXT(1)="Enter Y to save the patient to a Reminder Patient List. Enter N to not save the output."
+ ;
+ I CALL=4 D
+ .S HTEXT(1)="Enter Y to turn on Debug output."
+ .S HTEXT(2)="The debug output will send a series of mailman message to the requestor of the report"
+ .S HTEXT(3)="**WARNING** the reminder report will take longer to run if you turn on this option!"
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+PLIST(LIST,TEXT,IENO) ;Select Patient List
+ N X,Y,DIC,DLAYGO
+PL1 S DIC=810.5,DLAYGO=DIC,DIC(0)="QAEMZL"
+ S DIC("A")=TEXT
+ S DIC("S")="I $P($G(^(100)),U)'=""N"""
+ S DIC("DR")="100///L"
+ W !
+ D ^DIC
+ I X="" W !,"A patient list name must be entered" G PL1
+ I X=(U_U) S DTOUT=1
+ I Y=-1 S DUOUT=1
+ I $D(DTOUT)!$D(DUOUT) Q
+ ;
+ ;I copy mode dissallow copy to same list
+ I IENO=$P(Y,U) W !,"A patient list cannot be copied to itself." G PL1
+ ;
+ I ($P(Y,U,3)=1) S LIST=$P(Y,U) Q
+ ;Check if OK to overwrite
+ N OWRITE
+ S OWRITE=$$ASKYN^PXRMEUT("N","Okay to overwite "_$P(Y,U,2),"PXRMLCR",1)
+ Q:$D(DTOUT)  G:$D(DUOUT)!('OWRITE) PL1
+ S OWRITE=$$LDELOK^PXRMEUT($P(Y,U,1))
+ I 'OWRITE D  G PL1
+ . W !,"In order to overwrite a list you must be the creator or a Reminder Manager!"
+ ;Return list ien
+ S LIST=$P(Y,U)
+ Q
+ ;
+LRULE(RULE) ;Select List Rule
+ N X,Y,DIC
+LR1 S DIC=810.4,DIC(0)="QAEMZ"
+ S DIC("A")="Select LIST RULE SET: "
+ ;Only allow rule sets with components
+ S DIC("S")="I $P(^(0),U,3)=3"
+ W !
+ D ^DIC
+ I X="" W !,"A list rule set name must be entered" G LR1
+ I X=(U_U) S DTOUT=1
+ I Y=-1 S DUOUT=1
+ I $D(DTOUT)!$D(DUOUT) Q
+ ;Return rule ien
+ S RULE=$P(Y,U)
+ ;Check that rule set is valid
+ N ERROR,LR,LRTYPE,NL,OP,SEQ,SUB,TEMP,TEXT
+ S SUB=$O(^PXRM(810.4,RULE,30,0))
+ I SUB="" W !,"Rule set has no component rules" G LR1
+ S (ERROR,SUB)=0,NL=1
+ F  S SUB=$O(^PXRM(810.4,RULE,30,SUB)) Q:'SUB  D  Q:ERROR
+ .S TEMP=$G(^PXRM(810.4,RULE,30,SUB,0))
+ .S SEQ=$P(TEMP,U,1),LR=$P(TEMP,U,2),OP=$P(TEMP,U,3)
+ .I SEQ="" S NL=NL+1,TEXT(NL)=" Sequence is missing.",ERROR=1
+ .I LR="" S NL=NL+1,TEXT(NL)=" List rule is missing.",ERROR=1
+ .I OP="" S NL=NL+1,TEXT(NL)=" Operation is missing.",ERROR=1
+ .;The Insert operation can only be used with finding rules.
+ .I OP="F",LR'="" D
+ ..S LRTYPE=$P(^PXRM(810.4,LR,0),U,3)
+ ..I LRTYPE'=1 S NL=NL+1,TEXT(NL)=" Insert operation can only be used with finding rules.",ERROR=1
+ I ERROR D  G LR1
+ .S TEXT(1)="The rule set is incomplete or incorrect:"
+ .D EN^DDIOL(.TEXT)
+ Q
+ ;
+ ;Build list and clear ^TMP files
+RUN(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) ;
+ ;Process rule set and update final patient list
+ D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT)
+ ;Clear ^TMP lists created for rule
+ D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
+ Q
+ ;
+REMOVE(IEN) ;
+ S $P(^PXRM(810.4,IEN,0),U,10)=""
+ Q "@1"
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m

@@ -1 @@
-PXRMLIST        ; SLC/PKR/PJH - Clinical Reminders list functions. ;07/17/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;Used in the reminder exchange utility for building lists of
-        ;reminders, Exchange File entries, etc.
-        ;=======================================================
-FRDEF(NAME,PNAME)       ;Format the reminder name and print name.
-        N IND,TEMP
-        S TEMP=$$LJ^XLFSTR(NAME,40," ")
-        S TEMP=TEMP_PNAME
-        Q TEMP
-        ;
-        ;=======================================================
-FMT(NUMBER,NAME,SOURCE,DATE,FMTSTR,NL,OUTPUT)   ;Format  entry number, name,
-        ;source, and date packed for LM display.
-        N TEMP,TSOURCE
-        S TEMP=NUMBER_U_NAME
-        S TSOURCE=$E($P(SOURCE,",",1),1,12)_"@"_$E($P(SOURCE," at ",2),1,12)
-        S TEMP=TEMP_U_TSOURCE
-        S DATE=$$FMTE^XLFDT(DATE,"5Z")
-        S TEMP=TEMP_U_DATE
-        D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NL,.OUTPUT)
-        Q
-        ;
-        ;=======================================================
-LIST    ;Print a list of location lists.
-        N BY,DIC,FLDS,FR,L,PXRMEDOK
-        S PXRMEDOK=1
-        S BY=".01"
-        S DIC="^PXRMD(810.9,"
-        S FLDS="[PXRM LOCATION LIST LIST]"
-        S FR=""
-        S L=0
-        D EN1^DIP
-        Q
-        ;
-        ;=======================================================
-MRKINACT(TEXT)  ;Append the inactive mark to TEXT in column 77.
-        N IC,NSPA
-        S NSPA=77-$L(TEXT)
-        F IC=1:1:NSPA S TEXT=TEXT_" "
-        S TEXT=TEXT_"X"
-        Q TEXT
-        ;
-        ;=======================================================
-QUERYAO()       ;See if the user wants only active reminders listed.
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
-        S DIR(0)="YA"
-        S DIR("A")="List active reminders only? "
-        S DIR("B")="Y"
-        W !
-        D ^DIR
-        Q Y
-        ;
-        ;=======================================================
-RDEF(DEFLIST,ARO)       ;Build a list of the name and print name of all
-        ;reminder definitions.
-        N INACTIVE,IEN,NAME,PNAME,REMINDER
-        S INACTIVE=""
-        ;Build the list of reminders in alphabetical order.
-        S VALMCNT=0
-        S NAME=""
-        F  S NAME=$O(^PXD(811.9,"B",NAME)) Q:NAME=""  D
-        . S IEN=$O(^PXD(811.9,"B",NAME,""))
-        . S REMINDER=^PXD(811.9,IEN,0)
-        . S INACTIVE=$P(REMINDER,U,6)
-        . I (ARO)&(INACTIVE) Q
-        . S VALMCNT=VALMCNT+1
-        . S PNAME=$P(REMINDER,U,3)
-        . S DEFLIST(VALMCNT,0)=$$FRDEF(NAME,PNAME)
-        . I INACTIVE D
-        .. S DEFLIST(VALMCNT,0)=$$MRKINACT(DEFLIST(VALMCNT,0))
-        S DEFLIST("VALMCNT")=VALMCNT
-        Q
-        ;
-        ;=======================================================
-REXL(RLIST)     ;Build a list of exchange repository entries.
-        N DATE,EXIEN,FMTSTR,IND,NAME,NL,NUM,OUTPUT,SOURCE,STR
-        ;Build the list in alphabetical order.
-        S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLL")
-        S (NUM,VALMCNT)=0
-        S NAME=""
-        F  S NAME=$O(^PXD(811.8,"B",NAME)) Q:NAME=""  D
-        . S DATE=""
-        . F  S DATE=$O(^PXD(811.8,"B",NAME,DATE)) Q:DATE=""  D
-        .. S EXIEN=$O(^PXD(811.8,"B",NAME,DATE,""))
-        .. S SOURCE=$P(^PXD(811.8,EXIEN,0),U,2)
-        .. S NUM=NUM+1
-        .. S ^TMP(RLIST,$J,"SEL",NUM)=EXIEN
-        .. D FMT(NUM,NAME,SOURCE,DATE,FMTSTR,.NL,.OUTPUT)
-        .. F IND=1:1:NL D
-        ... S VALMCNT=VALMCNT+1,^TMP(RLIST,$J,VALMCNT,0)=OUTPUT(IND)
-        ... S ^TMP(RLIST,$J,"IDX",VALMCNT,NUM)=""
-        S ^TMP(RLIST,$J,"VALMCNT")=VALMCNT
-        Q
-        ;
-        ;=======================================================
-SPONSOR ;Print a list of Sponsors.
-        N BY,DIC,FLDS,FR,L,PXRMEDOK
-        S PXRMEDOK=1
-        S BY=".01"
-        S DIC="^PXRMD(811.6,"
-        S FLDS="[PXRM SPONSOR LIST]"
-        S FR=""
-        S L=0
-        D EN1^DIP
-        Q
-        ;
+PXRMLIST ; SLC/PKR/PJH - Clinical Reminders list functions. ;10/04/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;Used in the reminder exchange utility for building lists of
+ ;reminders, Exchange File entries, etc.
+ ;=======================================================
+FRDEF(NAME,PNAME) ;Format the reminder name and print name.
+ N IND,TEMP
+ S TEMP=$$LJ^XLFSTR(NAME,40," ")
+ S TEMP=TEMP_PNAME
+ Q TEMP
+ ;
+ ;=======================================================
+FRE(NUMBER,NAME,SOURCE,DATE) ;Format  entry number, name, source,
+ ;and date packed.
+ N TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,4," ")
+ S TNAME=$E(NAME,1,27)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,29," ")
+ S TSOURCE=$E($P(SOURCE,",",1),1,12)_"@"_$E($P(SOURCE," at ",2),1,12)
+ S TEMP=TEMP_$$LJ^XLFSTR(TSOURCE,23," ")
+ S DATE=$$FMTE^XLFDT(DATE,"5Z")
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DATE,30," ")
+ Q TEMP
+ ;
+ ;=======================================================
+LIST ;Print a list of location lists.
+ N BY,DIC,FLDS,FR,L,PXRMEDOK
+ S PXRMEDOK=1
+ S BY=".01"
+ S DIC="^PXRMD(810.9,"
+ S FLDS="[PXRM LOCATION LIST LIST]"
+ S FR=""
+ S L=0
+ D EN1^DIP
+ Q
+ ;
+ ;=======================================================
+MRKINACT(TEXT) ;Append the inactive mark to TEXT in column 77.
+ N IC,NSPA
+ S NSPA=77-$L(TEXT)
+ F IC=1:1:NSPA S TEXT=TEXT_" "
+ S TEXT=TEXT_"X"
+ Q TEXT
+ ;
+ ;=======================================================
+QUERYAO() ;See if the user wants only active reminders listed.
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S DIR(0)="YA"
+ S DIR("A")="List active reminders only? "
+ S DIR("B")="Y"
+ W !
+ D ^DIR
+ Q Y
+ ;
+ ;=======================================================
+RDEF(DEFLIST,ARO) ;Build a list of the name and print name of all
+ ;reminder definitions.
+ N INACTIVE,IEN,NAME,PNAME,REMINDER
+ S INACTIVE=""
+ ;Build the list of reminders in alphabetical order.
+ S VALMCNT=0
+ S NAME=""
+ F  S NAME=$O(^PXD(811.9,"B",NAME)) Q:NAME=""  D
+ . S IEN=$O(^PXD(811.9,"B",NAME,""))
+ . S REMINDER=^PXD(811.9,IEN,0)
+ . S INACTIVE=$P(REMINDER,U,6)
+ . I (ARO)&(INACTIVE) Q
+ . S VALMCNT=VALMCNT+1
+ . S PNAME=$P(REMINDER,U,3)
+ . S DEFLIST(VALMCNT,0)=$$FRDEF(NAME,PNAME)
+ . I INACTIVE D
+ .. S DEFLIST(VALMCNT,0)=$$MRKINACT(DEFLIST(VALMCNT,0))
+ S DEFLIST("VALMCNT")=VALMCNT
+ Q
+ ;
+ ;=======================================================
+RE(RLIST,IEN) ;Build a list of repository entries.
+ N DATE,IND,NAME,SOURCE
+ ;Build the list in alphabetical order.
+ S VALMCNT=0
+ S NAME=""
+ F  S NAME=$O(^PXD(811.8,"B",NAME)) Q:NAME=""  D
+ . S DATE=""
+ . F  S DATE=$O(^PXD(811.8,"B",NAME,DATE)) Q:DATE=""  D
+ .. S IND=$O(^PXD(811.8,"B",NAME,DATE,""))
+ .. S SOURCE=$P(^PXD(811.8,IND,0),U,2)
+ .. S VALMCNT=VALMCNT+1
+ .. S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,SOURCE,DATE)
+ .. S IEN(VALMCNT)=IND
+ S RLIST("VALMCNT")=VALMCNT
+ Q
+ ;
+ ;=======================================================
+SPONSOR ;Print a list of Sponsors.
+ N BY,DIC,FLDS,FR,L,PXRMEDOK
+ S PXRMEDOK=1
+ S BY=".01"
+ S DIC="^PXRMD(811.6,"
+ S FLDS="[PXRM SPONSOR LIST]"
+ S FR=""
+ S L=0
+ D EN1^DIP
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m

@@ -1 @@
-PXRMLLED        ; SLC/PJH - Edit a location list. ;06/25/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;================================================================
-        N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,FILEA,IENA,NUM,Y
-GETNAME ;Get the name of the location list to edit.
-        K DA,DIC,DLAYGO,DTOUT,DUOUT,Y
-        S DIC="^PXRMD(810.9,"
-        S DIC(0)="AEMQL"
-        S DIC("A")="Select Location List: "
-        S DIC("S")="I $$VEDIT^PXRMUTIL(DIC,Y)"
-        S DLAYGO=810.9
-        ;Set the starting place for additions.
-        D SETSTART^PXRMCOPY(DIC)
-        W !
-        D ^DIC
-        I ($D(DTOUT))!($D(DUOUT)) Q
-        I Y=-1 G END
-        S DA=$P(Y,U,1)
-        S CS1=$$FILE^PXRMEXCS(810.9,DA)
-        D EDIT(DIC,DA)
-        ;See if any changes have been made, if so do the edit history.
-        S CS2=$$FILE^PXRMEXCS(810.9,DA)
-        I CS2'=0,CS2'=CS1 D SEHIST^PXRMUTIL(810.9,DIC,DA)
-        G GETNAME
-END     ;
-        Q
-        ;
-        ;================================================================
-EDIT(ROOT,DA)   ;
-        N DIE,DR,DIDEL,X,Y
-        S DIE=ROOT,DIDEL=810.9
-NAME    S DR=".01"
-        D ^DIE
-        I '$D(DA) Q
-        I $D(Y) Q
-CLASS   ;
-        ;Class
-RETRY   W !!
-        S DR="100"
-        D ^DIE
-        I $D(Y) G NAME
-        ;Sponsor
-        S DR="101"
-        D ^DIE
-        I $D(Y) G RETRY
-        ;Make sure Class and Sponsor Class are in synch.
-        S RESULT=$$VSPONSOR^PXRMINTR(X)
-        I RESULT=0 S DIE("NO^")="Other value" G RETRY
-        I RESULT=1 K DIE("NO^")
-        ;Review date
-RD      W !!
-        S DR="102"
-        D ^DIE
-        I $D(Y) G RETRY
-        ;
-        ;Description
-DES     S DR="1"
-        D ^DIE
-        I $D(Y) G RD
-        ;
-        ;Clinic Stops
-CS      S DR="40.7"
-        S DR(2,810.9001)=".01;1"
-        D ^DIE
-        I $D(Y) G RD
-        ;
-        ;Hospital Locations
-HL      S DR="44"
-        D ^DIE
-        I $D(Y) G CS
-        Q
-        ;
-        ;================================================================
-KAMIS(X,DA)     ;Kill the AMIS Reporting Stop Code.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)=""
-        Q
-        ;
-        ;================================================================
-SAMIS(X,DA)     ;Set the AMIS Reporting Stop Code.
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        N AMIS
-        S AMIS=$P(^DIC(40.7,X,0),U,2)
-        S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)=AMIS
-        Q
-        ;
+PXRMLLED ; SLC/PJH - Edit a location list. ;12/23/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;================================================================
+ N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,FILEA,IENA,NUM,Y
+GETNAME ;Get the name of the location list to edit.
+ K DA,DIC,DLAYGO,DTOUT,DUOUT,Y
+ S DIC="^PXRMD(810.9,"
+ S DIC(0)="AEMQL"
+ S DIC("A")="Select Location List: "
+ S DIC("S")="I $$VEDIT^PXRMUTIL(DIC,Y)"
+ S DLAYGO=810.9
+ ;Set the starting place for additions.
+ D SETSTART^PXRMCOPY(DIC)
+ W !
+ D ^DIC
+ I ($D(DTOUT))!($D(DUOUT)) Q
+ I Y=-1 G END
+ S DA=$P(Y,U,1)
+ S CS1=$$FILE^PXRMEXCS(810.9,DA)
+ D EDIT(DIC,DA)
+ ;See if any changes have been made, if so do the edit history.
+ S CS2=$$FILE^PXRMEXCS(810.9,DA)
+ I CS2'=0,CS2'=CS1 D SEHIST^PXRMUTIL(810.9,DIC,DA)
+ G GETNAME
+END ;
+ Q
+ ;
+ ;================================================================
+EDIT(ROOT,DA) ;
+ N DIE,DR,DIDEL,X,Y
+ S DIE=ROOT,DIDEL=810.9
+NAME S DR=".01"
+ D ^DIE
+ I '$D(DA) Q
+ I $D(Y) Q
+CLASS ;
+ ;Class
+RETRY W !!
+ S DR="100"
+ D ^DIE
+ I $D(Y) G NAME
+ ;Sponsor
+ S DR="101"
+ D ^DIE
+ I $D(Y) G RETRY
+ ;Make sure Class and Sponsor Class are in synch.
+ S RESULT=$$VSPONSOR^PXRMINTR(X)
+ I RESULT=0 S DIE("NO^")="Other value" G RETRY
+ I RESULT=1 K DIE("NO^")
+ ;Review date
+RD W !!
+ S DR="102"
+ D ^DIE
+ I $D(Y) G RETRY
+ ;
+ ;Description
+DES S DR="1"
+ D ^DIE
+ I $D(Y) G RD
+ ;
+ ;Clinic Stops
+CS S DR="40.7"
+ S DR(2,810.9001)=".01;1"
+ D ^DIE
+ I $D(Y) G DES
+ ;
+ ;Hospital Locations
+HL S DR="44"
+ D ^DIE
+ I $D(Y) G CS
+ Q
+ ;
+ ;================================================================
+KAMIS(X,DA) ;Kill the AMIS Reporting Stop Code.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)=""
+ Q
+ ;
+ ;================================================================
+SAMIS(X,DA) ;Set the AMIS Reporting Stop Code.
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ N AMIS
+ S AMIS=$P(^DIC(40.7,X,0),U,2)
+ S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)=AMIS
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m

@@ -1 @@
-PXRMLOCF        ; SLC/PKR - Handle location findings. ;10/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;This routine is for location list patient findings.
-        ;=================================================
-ALL(FILENUM,DFN,PFINDPA,FIEVAL) ;Get all Visits with a location
-        ;for a patient.
-        N BDT,BTIME,CASESEN,COND,CONVAL,DAS,DATE,DEND,DONE,DS,EDT,FIEVD
-        N ICOND,INVBD,INVDATE,INVDT,INVED,NFOUND,NOCC
-        N SAVE,SDIR,TEMP,TIME,UCIFS
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
-        S SDIR=$S(NOCC<0:-1,1:1)
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        S (DONE,NFOUND)=0
-        S DEND=$S(EDT[".":EDT,1:EDT+.235959)
-        S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
-        S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
-        I SDIR=1 S DS=INVED-.000001
-        I SDIR=-1 S DS=INVBD+.000001
-        S INVDT=DS,(DONE,NFOUND)=0
-        ;DBIA 2028
-        F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(DONE)!(INVDT="")  D
-        . S INVDATE=$P(INVDT,".",1)
-        . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
-        . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
-        . S TIME="."_$P(INVDT,".",2)
-        . I INVDATE=INVED,TIME>ETIME Q
-        . I INVDATE=INVBD,TIME<BTIME Q
-        . S DAS=0
-        . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D
-        .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
-        .. S CONVAL=$S(COND="":1,1:$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD))
-        .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        .. I SAVE D
-        ... S TEMP=^AUPNVSIT(DAS,0)
-        ... S NFOUND=NFOUND+1
-        ... S FIEVAL(NFOUND)=CONVAL
-        ... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL
-        ... S FIEVAL(NFOUND,"DAS")=DAS
-        ... S FIEVAL(NFOUND,"DATE")=$P(TEMP,U,1)
-        ... M FIEVAL(NFOUND)=FIEVD
-        ... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD
-        ... I NFOUND=NOCC S DONE=1
-        ;Save the finding result.
-        D SFRES^PXRMUTIL(-SDIR,NFOUND,.FIEVAL)
-        S FIEVAL("FILE NUMBER")=FILENUM
-        Q
-        ;
-        ;=================================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate location findings.
-        N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        S ITEM=""
-        F  S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0  D
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0  D
-        .. K FINDPA
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. K FIEVT
-        .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)
-        .. M FIEVAL(FINDING)=FIEVT
-        .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
-        Q
-        ;
-        ;=================================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;Evaluate location terms.
-        N FIEVT,FILENUM,ITEM,PFINDPA
-        N TEMP,TFINDING,TFINDPA
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        S ITEM=""
-        F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
-        .. K FIEVT,PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
-        .. M TFIEVAL(TFINDING)=FIEVT
-        .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
-        Q
-        ;
-        ;=================================================
-FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL)   ;
-        ;Evaluate regular patient findings.
-        N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,HLOC
-        N ICOND,IND,LNAME,NFOUND,NGET,NOCC,NP
-        N SAVE,SDIR,STATUSA,TEMP,UCIFS,VSLIST
-        S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)
-        I LNAME="VA-ALL LOCATIONS" D ALL(FILENUM,DFN,.PFINDPA,.FIEVAL) Q
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
-        S SDIR=$S(NOCC<0:-1,1:1)
-        D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
-        ;Get a list of unique locations.
-        D LOCLIST(ITEM,"HLOCL")
-        D FPDAT(DFN,"HLOCL",NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
-        I NFOUND=0 S FIEVAL=0 Q
-        S NP=0
-        F IND=1:1:NFOUND Q:NP=NOCC  D
-        . S DAS=$P(FLIST(IND),U,1)
-        . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
-        . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
-        . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        . I SAVE D
-        .. S NP=NP+1
-        .. S FIEVAL(NP)=CONVAL
-        .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
-        .. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1)
-        .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
-        .. M FIEVAL(NP)=FIEVD
-        .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD
-        ;
-        ;Save the finding result.
-        D SFRES^PXRMUTIL(NOCC,NP,.FIEVAL)
-        S FIEVAL("FILE NUMBER")=FILENUM
-        Q
-        ;
-        ;=================================================
-FPDAT(DFN,HLOCL,NOCC,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient data for
-        ;visits at a specified hospital location. Return up to NOCC most
-        ;recent entries in FLIST where FLIST(1) is the most recent.
-        ;"AA" in Visit file is inverse date_.time instead of a full inverse
-        ;date and time. For example if the date/time is 3030704.104449 then
-        ;"AA" has 6969295.104449 instead of 6969295.89555
-        N BTIME,DAS,DATE,DEND,DLIST,DONE,DS,ETIME,HLOC
-        N INVBD,INVDATE,INVDT,INVED,NF,TEMP,TIME
-        S DEND=$S(EDT[".":EDT,1:EDT+.235959)
-        S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
-        S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
-        I SDIR=1 S DS=INVED-.000001
-        I SDIR=-1 S DS=INVBD+.000001
-        ;DBIA #2028
-        S INVDT=DS,(DONE,NFOUND)=0
-        F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(INVDT="")!(DONE)  D
-        . S NF=0
-        . S INVDATE=$P(INVDT,".",1)
-        . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
-        . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
-        . S TIME="."_$P(INVDT,".",2)
-        . I INVDATE=INVED,TIME>ETIME Q
-        . I INVDATE=INVBD,TIME<BTIME Q
-        . S DAS=0
-        . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D
-        .. S TEMP=^AUPNVSIT(DAS,0)
-        .. S HLOC=$P(TEMP,U,22)
-        .. I HLOC="" Q
-        .. I '$D(^TMP($J,HLOCL,HLOC)) Q
-        ..;Check the associated appointment for a valid status.
-        .. I '$$VAPSTAT^PXRMVSIT(DAS) Q
-        .. S DATE=$P(TEMP,U,1)
-        .. S NF=NF+1,NFOUND=NFOUND+1
-        .. I NFOUND=NOCC S DONE=1
-        .. S DLIST(INVDT,NF)=DAS_U_DATE
-        S INVDT="",NFOUND=0
-        F  S INVDT=$O(DLIST(INVDT)) Q:INVDT=""  D
-        . S NF=0
-        . F  S NF=$O(DLIST(INVDT,NF)) Q:NF=""  D
-        .. S NFOUND=NFOUND+1
-        .. S FLIST(NFOUND)=DLIST(INVDT,NF)
-        K ^TMP($J,"HLOCL")
-        Q
-        ;
-        ;=================================================
-LOCLIST(ITEM,SUB)       ;Build a list of unique locations based on stop code
-        ;and/or hospital location. Reads of ^SC covered by DBIA #4482.
-        N CS,EXCL,IND,JND,HLOC,SC
-        K ^TMP($J,SUB)
-        ;Process stop codes. EXCL is the list of credit stops to exclude.
-        S IND=0
-        F  S IND=+$O(^PXRMD(810.9,ITEM,40.7,IND)) Q:IND=0  D
-        . S SC=$P(^PXRMD(810.9,ITEM,40.7,IND,0),U,1)
-        . K EXCL
-        . S JND=0
-        . F  S JND=+$O(^PXRMD(810.9,ITEM,40.7,IND,1,JND)) Q:JND=0  D
-        .. S EXCL=^PXRMD(810.9,ITEM,40.7,IND,1,JND,0)
-        .. S EXCL(EXCL)=""
-        . S HLOC=""
-        . F  S HLOC=$O(^SC("AST",SC,HLOC)) Q:HLOC=""  D
-        .. ;See if there are any to exclude.
-        .. S CS=$P(^SC(HLOC,0),U,18)
-        .. I CS'="",$D(EXCL(CS)) Q
-        .. S ^TMP($J,SUB,HLOC)=""
-        ;Process locations.
-        S IND=0
-        F  S IND=+$O(^PXRMD(810.9,ITEM,44,IND)) Q:IND=0  D
-        . S HLOC=^PXRMD(810.9,ITEM,44,IND,0)
-        . S ^TMP($J,SUB,HLOC)=""
-        Q
-        ;
-        ;=================================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
-        N HLOC,IND,JND,LOC,NAME,NIN,NOUT,SC,TEMP,TEXTIN,TEXTOUT,VDATE
-        S NAME="Outpatient Encounter = "
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S NIN=0
-        . S VDATE=IFIEVAL(IND,"DATE")
-        . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
-        . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))
-        . S SC=$G(IFIEVAL(IND,"DSS ID"))
-        . S SC=$S(SC="":"?",1:" "_$P($G(^DIC(40.7,SC,0)),U,1))
-        . S HLOC=$G(IFIEVAL(IND,"HOSPITAL LOCATION"))
-        . S HLOC=$S(HLOC="":"?",1:" "_$P($G(^SC(HLOC,0)),U,1))
-        . S TEMP=NAME_LOC_HLOC_SC_" ("_$$EDATE^PXRMDATE(VDATE)_")"
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;=================================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
-        N EM,HLOC,IND,JND,LOC,NIN,NOUT,SC,STATUS,TEMP,TEXTIN,TEXTOUT,VDATE
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"PCE Encounter:"
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S NIN=0
-        . S VDATE=IFIEVAL(IND,"DATE")
-        . S TEMP=$$EDATE^PXRMDATE(VDATE)
-        . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
-        . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))
-        . S TEMP=TEMP_" Facility - "_LOC
-        . D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        . S HLOC=$G(IFIEVAL(IND,"HLOC"))
-        . I HLOC="" S HLOC="?"
-        . S TEMP="Hospital Location: "_HLOC
-        . S SC=$G(IFIEVAL(IND,"STOP CODE"))
-        . I SC="" S SC="?"
-        . S TEMP=TEMP_"; Clinic Stop: "_SC
-        . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
-        . S SC=$G(IFIEVAL(IND,"SERVICE CATEGORY"))
-        . S TEMP="Service Category: "_SC_"="_$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
-        . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
-        . S STATUS=$P($G(IFIEVAL(IND,"STATUS")),U,2)
-        . I STATUS="" S STATUS="?"
-        . S TEMP="Appointment Status: "_STATUS
-        . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
-        . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        . I IFIEVAL(IND,"COMMENTS")'="" D
-        .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
-        .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
+PXRMLOCF ; SLC/PKR - Handle location findings. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;This routine is for location list patient findings.
+ ;=================================================
+ALL(FILENUM,DFN,PFINDPA,FIEVAL) ;Get all Visits with a location
+ ;for a patient.
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,DONE,EDT,ENTYPE,FIEVD,HLOC
+ N ICOND,IND,NFOUND,NOCC
+ N SAVE,SDIR,TEMP,UCIFS,VDATE
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S (DONE,NFOUND)=0
+ I SDIR=1 S VDATE=BDT-.0000001
+ I SDIR=-1 S VDATE=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ ;DBIA 2028
+ F  S VDATE=+$O(^AUPNVSIT("AET",DFN,VDATE),SDIR) Q:(VDATE=0)!(DONE)  D
+ . I SDIR=1,VDATE>EDT S DONE=1 Q
+ . I SDIR=-1,VDATE<BDT S DONE=1 Q
+ . S HLOC=""
+ . F  S HLOC=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC)) Q:(HLOC="")!(DONE)  D
+ .. S ENTYPE=""
+ .. F  S ENTYPE=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC,ENTYPE)) Q:(ENTYPE="")!(DONE)  D
+ ... S DAS=0
+ ... F  S DAS=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC,ENTYPE,DAS)) Q:(DAS="")!(DONE)  D
+ .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ .... S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+ .... S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ .... I SAVE D
+ ..... S NFOUND=NFOUND+1
+ ..... S FIEVAL(NFOUND)=CONVAL
+ ..... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL
+ ..... S FIEVAL(NFOUND,"DAS")=DAS
+ ..... S FIEVAL(NFOUND,"DATE")=VDATE
+ ..... M FIEVAL(NFOUND)=FIEVD
+ ..... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD
+ ..... I NFOUND=NOCC S DONE=1
+ ;Save the finding result.
+ D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
+ S FIEVAL("FILE NUMBER")=FILENUM
+ Q
+ ;
+ ;=================================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate location findings.
+ N BDT,EDT,FIEVT,FILENUM,FINDING,FINDPA,ITEM
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ S ITEM=""
+ F  S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0  D
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0  D
+ .. K FINDPA
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. K FIEVT
+ .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.FINDPA,.FIEVT)
+ .. M FIEVAL(FINDING)=FIEVT
+ .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
+ Q
+ ;
+ ;=================================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate location terms.
+ N FIEVT,FILENUM,ITEM,PFINDPA
+ N TEMP,TFINDING,TFINDPA
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ S ITEM=""
+ F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
+ .. K FIEVT,PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D FIEVAL(FILENUM,"PI",DFN,ITEM,.PFINDPA,.FIEVT)
+ .. M TFIEVAL(TFINDING)=FIEVT
+ .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
+ Q
+ ;
+ ;=================================================
+FIEVAL(FILENUM,SNODE,DFN,ITEM,PFINDPA,FIEVAL) ;
+ ;Evaluate regular patient findings.
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,FIEVD,FLIST,HLOC
+ N ICOND,IND,LNAME,NFOUND,NGET,NOCC,NP
+ N SAVE,SDIR,STATUSA,TEMP,UCIFS,VSLIST
+ S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)
+ I LNAME="VA-ALL LOCATIONS" D ALL(FILENUM,DFN,.PFINDPA,.FIEVAL) Q
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
+ ;Get a list of unique locations.
+ D LOCLIST(ITEM,"HLOCL")
+ D FPDAT(DFN,"HLOCL",NGET,BDT,EDT,.NFOUND,.FLIST)
+ I NFOUND=0 S FIEVAL=0 Q
+ S NP=0
+ F IND=1:1:NFOUND Q:NP=NOCC  D
+ . S DAS=$P(FLIST(IND),U,1)
+ . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+ . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ . I SAVE D
+ .. S NP=NP+1
+ .. S FIEVAL(NP)=CONVAL
+ .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
+ .. S FIEVAL(NP,"DAS")=$P(FLIST(IND),U,1)
+ .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
+ .. M FIEVAL(NP)=FIEVD
+ .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVD
+ ;
+ ;Save the finding result.
+ D SFRES^PXRMUTIL(NOCC,NP,.FIEVAL)
+ S FIEVAL("FILE NUMBER")=FILENUM
+ Q
+ ;
+ ;=================================================
+FPDAT(DFN,HLOCL,NOCC,BDT,EDT,NFOUND,FLIST) ;Find patient data for
+ ;visits at a specified hospital location. Return up to NOCC most
+ ;recent entries in FLIST where FLIST(1) is the most recent.
+ N DAS,DATE,DLIST,ENTYPE,HLOC,NF
+ S NFOUND=0
+ S DATE=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ ;DBIA 2028
+ F  S DATE=+$O(^AUPNVSIT("AET",DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC)  D
+ . S HLOC=""
+ . F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:(HLOC="")!(NFOUND=NOCC)  D
+ .. I '$D(^AUPNVSIT("AET",DFN,DATE,HLOC)) Q
+ .. S NF=0
+ .. S ENTYPE=""
+ .. F  S ENTYPE=$O(^AUPNVSIT("AET",DFN,DATE,HLOC,ENTYPE)) Q:(ENTYPE="")!(NFOUND=NOCC)  D
+ ... S DAS=0
+ ... F  S DAS=$O(^AUPNVSIT("AET",DFN,DATE,HLOC,ENTYPE,DAS)) Q:(DAS="")!(NFOUND=NOCC)  D
+ ....;Check the associated appointment for a valid status.
+ .... I '$$VAPSTAT^PXRMVSIT(DAS) Q
+ .... S NF=NF+1,NFOUND=NFOUND+1
+ .... S DLIST(DATE,NF)=DAS
+ S NFOUND=0
+ S DATE=""
+ F  S DATE=$O(DLIST(DATE),-1) Q:DATE=""  D
+ . S NF=0
+ . F  S NF=$O(DLIST(DATE,NF)) Q:NF=""  D
+ .. S NFOUND=NFOUND+1
+ .. S FLIST(NFOUND)=DLIST(DATE,NF)_U_DATE
+ K ^TMP($J,"HLOCL")
+ Q
+ ;
+ ;=================================================
+LOCLIST(ITEM,SUB) ;Build a list of unique locations based on stop code
+ ;and/or hospital location. Reads of ^SC covered by DBIA #4482.
+ N CS,EXCL,IND,JND,HLOC,SC
+ K ^TMP($J,SUB)
+ ;Process stop codes. EXCL is the list of credit stops to exclude.
+ S IND=0
+ F  S IND=+$O(^PXRMD(810.9,ITEM,40.7,IND)) Q:IND=0  D
+ . S SC=$P(^PXRMD(810.9,ITEM,40.7,IND,0),U,1)
+ . K EXCL
+ . S JND=0
+ . F  S JND=+$O(^PXRMD(810.9,ITEM,40.7,IND,1,JND)) Q:JND=0  D
+ .. S EXCL=^PXRMD(810.9,ITEM,40.7,IND,1,JND,0)
+ .. S EXCL(EXCL)=""
+ . S HLOC=""
+ . F  S HLOC=$O(^SC("AST",SC,HLOC)) Q:HLOC=""  D
+ .. ;See if there are any to exclude.
+ .. S CS=$P(^SC(HLOC,0),U,18)
+ .. I CS'="",$D(EXCL(CS)) Q
+ .. S ^TMP($J,SUB,HLOC)=""
+ ;Process locations.
+ S IND=0
+ F  S IND=+$O(^PXRMD(810.9,ITEM,44,IND)) Q:IND=0  D
+ . S HLOC=^PXRMD(810.9,ITEM,44,IND,0)
+ . S ^TMP($J,SUB,HLOC)=""
+ Q
+ ;
+ ;=================================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
+ N HLOC,IND,JND,LOC,NAME,NIN,NOUT,SC,TEMP,TEXTIN,TEXTOUT,VDATE
+ S NAME="Outpatient Encounter = "
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S NIN=0
+ . S VDATE=IFIEVAL(IND,"DATE")
+ . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
+ . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))
+ . S SC=$G(IFIEVAL(IND,"DSS ID"))
+ . S SC=$S(SC="":"?",1:" "_$P($G(^DIC(40.7,SC,0)),U,1))
+ . S HLOC=$G(IFIEVAL(IND,"HOSPITAL LOCATION"))
+ . S HLOC=$S(HLOC="":"?",1:" "_$P($G(^SC(HLOC,0)),U,1))
+ . S TEMP=NAME_LOC_HLOC_SC_" ("_$$EDATE^PXRMDATE(VDATE)_")"
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;=================================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ ;DBIAs (^DIC(4: #10090), (^DIC(40.7: #557), (^SC: #10040)
+ N EM,HLOC,IND,JND,LOC,NIN,NOUT,SC,STATUS,TEMP,TEXTIN,TEXTOUT,VDATE
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"PCE Encounter:"
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S NIN=0
+ . S VDATE=IFIEVAL(IND,"DATE")
+ . S TEMP=$$EDATE^PXRMDATE(VDATE)
+ . S LOC=$G(IFIEVAL(IND,"LOC. OF ENCOUNTER"))
+ . S LOC=$S(LOC="":"?",1:$P($G(^DIC(4,LOC,0)),U,1))
+ . S TEMP=TEMP_" Facility - "_LOC
+ . D FORMATS^PXRMTEXT(INDENT+1,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ . S HLOC=$G(IFIEVAL(IND,"HLOC"))
+ . I HLOC="" S HLOC="?"
+ . S TEMP="Hospital Location: "_HLOC
+ . S SC=$G(IFIEVAL(IND,"STOP CODE"))
+ . I SC="" S SC="?"
+ . S TEMP=TEMP_"; Clinic Stop: "_SC
+ . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
+ . S SC=$G(IFIEVAL(IND,"SERVICE CATEGORY"))
+ . S TEMP="Service Category: "_SC_"="_$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
+ . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
+ . S STATUS=$P($G(IFIEVAL(IND,"STATUS")),U,2)
+ . I STATUS="" S STATUS="?"
+ . S TEMP="Appointment Status: "_STATUS
+ . S NIN=NIN+1,TEXTIN(NIN)=TEMP_"\\"
+ . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ . I IFIEVAL(IND,"COMMENTS")'="" D
+ .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
+ .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLOCL.m

@@ -1 @@
-PXRMLOCL        ; SLC/PKR - Handle location findings. ;07/26/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;This routine is for location list patient lists.
-        ;=============================================
-ALLLOCS(SUB)    ;Build a list of all hospital locations associated
-        ;with Visit file entries.
-        N HLOC
-        K ^TMP($J,SUB)
-        S HLOC=""
-        ;DBIA #2028
-        F  S HLOC=$O(^AUPNVSIT("AHL",HLOC)) Q:HLOC=""  S ^TMP($J,SUB,HLOC)=""
-        Q
-        ;
-        ;=============================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;Evaluate location term findings
-        ;for patient lists. Return the list in ^TMP($J,PLIST)
-        N BDT,EDT,ITEM,FILENUM,PFINDPA
-        N STATUSA,TEMP,TFINDING,TFINDPA
-        S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
-        S ITEM=""
-        F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
-        .. K PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)
-        Q
-        ;
-        ;=============================================
-FPLIST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST)        ;Find patient list data for
-        ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
-        N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
-        N NFOUND,SC,TEMP,TGLIST,TIME
-        S TGLIST="FPLIST_PXRMLOCL"
-        K ^TMP($J,TGLIST)
-        S DEND=$S(EDT[".":EDT,1:EDT+.235959)
-        ;"AHL" in Visit file is inverse date_.time instead of a full inverse
-        ;date and time. For example if the date/time is 3030704.104449 then
-        ;"AHL" has 6969295.104449 instead of 6969295.89555
-        S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
-        S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
-        S DS=INVED-.000001
-        S HLOC=""
-        F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D
-        . S INVDT=DS,DONE=0
-        .;DBIA #2028
-        . F  S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="")  D
-        .. S INVDATE=$P(INVDT,".",1)
-        .. I INVDATE>INVBD S DONE=1 Q
-        .. S TIME="."_$P(INVDT,".",2)
-        .. I INVDATE=INVED,TIME>ETIME Q
-        .. I INVDATE=INVBD,TIME<BTIME Q
-        .. S DAS=0
-        .. F  S DAS=$O(^AUPNVSIT("AHL",HLOC,INVDT,DAS)) Q:DAS=""  D
-        ...;Check the associated appointment for a valid status.
-        ... I '$$VAPSTAT^PXRMVSIT(DAS) Q
-        ... S TEMP=^AUPNVSIT(DAS,0)
-        ... S DATE=$P(TEMP,U,1)
-        ... S DFN=$P(TEMP,U,5)
-        ... S SC=$P(TEMP,U,7)
-        ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC_U_SC
-        ;Return the NOCC most recent for each patient.
-        S DFN=0
-        F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
-        . S (INVDT,NFOUND)=0
-        . F  S INVDT=$O(^TMP($J,TGLIST,DFN,INVDT)) Q:(NFOUND=NOCC)!(INVDT="")  D
-        .. S DAS=""
-        .. F  S DAS=$O(^TMP($J,TGLIST,DFN,INVDT,DAS)) Q:(NFOUND=NOCC)!(DAS="")  D
-        ... S NFOUND=NFOUND+1
-        ... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_^TMP($J,TGLIST,DFN,INVDT,DAS)
-        K ^TMP($J,TGLIST)
-        Q
-        ;
-        ;=============================================
-FTEST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for
-        ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
-        N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
-        N NFOUND,TEMP,TGLIST,TIME
-        S TGLIST="FPLIST_PXRMLOCL"
-        K ^TMP($J,TGLIST)
-        S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
-        S HLOC=""
-        F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D
-        . S DATE=DS
-        . F  S DATE=+$O(^AUPNVSIT("AHDP",HLOC,DATE),-1) Q:(DATE=0)!(DATE<BDT)  D
-        .. S DFN=""
-        .. F  S DFN=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN)) Q:DFN=""  D
-        ... S SC=""
-        ... F  S SC=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN,SC)) Q:SC=""  D
-        .... S DAS=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN,SC,""))
-        .... I '$$VAPSTAT^PXRMVSIT(DAS) Q
-        .... S ^TMP($J,TGLIST,DFN,DATE,DAS)=HLOC
-        ;Return the NOCC most recent for each patient.
-        S DFN=0
-        F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
-        . S DATE="",NFOUND=0
-        . F  S DATE=$O(^TMP($J,TGLIST,DFN,DATE),-1) Q:(NFOUND=NOCC)!(DATE="")  D
-        .. S DAS=""
-        .. F  S DAS=$O(^TMP($J,TGLIST,DFN,DATE,DAS)) Q:(NFOUND=NOCC)!(DAS="")  D
-        ... S NFOUND=NFOUND+1
-        ... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE_U_^TMP($J,TGLIST,DFN,DATE,DAS)
-        K ^TMP($J,TGLIST)
-        Q
-        ;
-        ;=============================================
-GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST)        ;Add to the patient list.
-        ; Return the list in ^TMP($J,PLIST).
-        ;^TMP($J,PLIST,T/F,DFN,IND,FILENUM)=DAS^DATE^HLOC^VALUE
-        N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST
-        N ICOND,IEN,IND,IPLIST,LNAME,NOCC,NFOUND,NGET,NP,SAVE,STATUSA
-        N TEMP,TGLIST,TPLIST,UCIFS,VALUE,VSLIST
-        S TGLIST="GPLIST_PXRMLOCL"
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
-        ;Ignore negative occurrence count, date reversal not allowed in
-        ;patient lists.
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
-        ;Get a list of unique locations.
-        S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)
-        I LNAME="VA-ALL LOCATIONS" D ALLLOCS("HLOCL")
-        I LNAME'="VA-ALL LOCATIONS" D LOCLIST^PXRMLOCF(ITEM,"HLOCL")
-        D FPLIST(FILENUM,"HLOCL",NGET,BDT,EDT,TGLIST)
-        S DFN=""
-        F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
-        . K TPLIST
-        . M TPLIST=^TMP($J,TGLIST,DFN)
-        . S (IND,NFOUND)=0
-        . K IPLIST
-        . F  S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCC)  D
-        .. S TEMP=TPLIST(IND)
-        .. S DAS=$P(TEMP,U,1)
-        .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
-        .. S VALUE=$G(FIEVD("VALUE"))
-        .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
-        .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        .. I SAVE D
-        ... S NFOUND=NFOUND+1
-        ... S IPLIST(CONVAL,DFN,NFOUND,FILENUM)=TEMP_U_VALUE
-        . M ^TMP($J,PLIST)=IPLIST
-        K ^TMP($J,"HLOCL"),^TMP($J,TGLIST)
-        Q
-        ;
-        ;=============================================
-PCSTOPL ;Print the Clinic Stop list. Called by the print template PXRM
-        ;LOCATION LIST INQUIRY.
-        N AMIS,CSTOP,IND,JND,SKIP,TEMP
-        S (IND,SKIP)=0
-        F  S IND=+$O(^PXRMD(810.9,D0,40.7,IND)) Q:IND=0  D
-        . S TEMP=^PXRMD(810.9,D0,40.7,IND,0)
-        . S CSTOP=$P(TEMP,U,1)
-        .; DBIA #557
-        . S CSTOP=$P(^DIC(40.7,CSTOP,0),U,1)
-        . S AMIS=$P(TEMP,U,2)
-        . I SKIP W ! S SKIP=0
-        . W !,?2,CSTOP,?34,AMIS
-        . I '$D(^PXRMD(810.9,D0,40.7,IND,1)) Q
-        . S SKIP=1
-        . W !,?4,"Credit Stops to Exclude:"
-        . S JND=0
-        . F  S JND=+$O(^PXRMD(810.9,D0,40.7,IND,1,JND)) Q:JND=0  D
-        .. S TEMP=^PXRMD(810.9,D0,40.7,IND,1,JND,0)
-        .. S TEMP=$P(^DIC(40.7,TEMP,0),U,1,2)
-        .. S CSTOP=$P(TEMP,U,1)
-        .. S AMIS=$P(TEMP,U,2)
-        .. W !,?6,CSTOP,?38,AMIS
-        Q
-        ;
+PXRMLOCL ; SLC/PKR - Handle location findings. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;This routine is for location list patient lists.
+ ;=============================================
+ALLLOCS(SUB) ;Build a list of all hospital locations associated
+ ;with Visit file entries.
+ N HLOC
+ K ^TMP($J,SUB)
+ S HLOC=""
+ ;DBIA #2028
+ F  S HLOC=$O(^AUPNVSIT("AHL",HLOC)) Q:HLOC=""  S ^TMP($J,SUB,HLOC)=""
+ Q
+ ;
+ ;=============================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate location term findings
+ ;for patient lists. Return the list in ^TMP($J,PLIST)
+ N BDT,EDT,ITEM,FILENUM,PFINDPA
+ N STATUSA,TEMP,TFINDING,TFINDPA
+ S FILENUM=$$GETFNUM^PXRMDATA(ENODE)
+ S ITEM=""
+ F  S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0  D
+ .. K PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST)
+ Q
+ ;
+ ;=============================================
+FPLIST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for
+ ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
+ N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
+ N NFOUND,TEMP,TGLIST,TIME
+ S TGLIST="FPLIST_PXRMLOCL"
+ K ^TMP($J,TGLIST)
+ S DEND=$S(EDT[".":EDT,1:EDT+.240001)
+ ;"AHL" in Visit file is inverse date_.time instead of a full inverse
+ ;date and time. For example if the date/time is 3030704.104449 then
+ ;"AHL" has 6969295.104449 instead of 6969295.89555
+ S INVBD=9999999-$P(BDT,".",1),BTIME=+("."_$P(BDT,".",2))
+ S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2))
+ S DS=INVED-1
+ S HLOC=""
+ F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D
+ . S INVDT=DS,DONE=0
+ .;DBIA #2028
+ . F  S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="")  D
+ .. S INVDATE=$P(INVDT,".",1)
+ .. I INVDATE>INVBD S DONE=1 Q
+ .. S TIME=+("."_$P(INVDT,".",2))
+ .. I INVDATE=INVED,TIME>ETIME Q
+ .. I INVDATE=INVBD,BTIME>TIME S DONE=1 Q
+ .. S DAS=0
+ .. F  S DAS=$O(^AUPNVSIT("AHL",HLOC,INVDT,DAS)) Q:DAS=""  D
+ ...;Check the associated appointment for a valid status.
+ ... I '$$VAPSTAT^PXRMVSIT(DAS) Q
+ ... S TEMP=^AUPNVSIT(DAS,0)
+ ... S DFN=$P(TEMP,U,5)
+ ... S DATE=$P(TEMP,U,1)
+ ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC
+ ;Return the NOCC most recent for each patient.
+ S DFN=0
+ F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
+ . S (INVDT,NFOUND)=0
+ . F  S INVDT=$O(^TMP($J,TGLIST,DFN,INVDT)) Q:(NFOUND=NOCC)!(INVDT="")  D
+ .. S DAS=""
+ .. F  S DAS=$O(^TMP($J,TGLIST,DFN,INVDT,DAS)) Q:(NFOUND=NOCC)!(DAS="")  D
+ ... S NFOUND=NFOUND+1
+ ... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_^TMP($J,TGLIST,DFN,INVDT,DAS)
+ K ^TMP($J,TGLIST)
+ Q
+ ;
+ ;=============================================
+GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list.
+ ; Return the list in ^TMP($J,PLIST).
+ ;^TMP($J,PLIST,T/F,DFN,IND,FILENUM)=DAS^DATE^HLOC^VALUE
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST
+ N ICOND,IEN,IND,IPLIST,LNAME,NOCC,NFOUND,NGET,NP,SAVE,STATUSA
+ N TEMP,TGLIST,TPLIST,UCIFS,VALUE,VSLIST
+ S TGLIST="GPLIST_PXRMLOCL"
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
+ ;Get a list of unique locations.
+ S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)
+ I LNAME="VA-ALL LOCATIONS" D ALLLOCS("HLOCL")
+ I LNAME'="VA-ALL LOCATIONS" D LOCLIST^PXRMLOCF(ITEM,"HLOCL")
+ D FPLIST(FILENUM,"HLOCL",NGET,BDT,EDT,TGLIST)
+ S DFN=""
+ F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
+ . K TPLIST
+ . M TPLIST=^TMP($J,TGLIST,DFN)
+ . S (IND,NFOUND)=0
+ . K IPLIST
+ . F  S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCC)  D
+ .. S TEMP=TPLIST(IND)
+ .. S DAS=$P(TEMP,U,1)
+ .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ .. S VALUE=$G(FIEVD("VALUE"))
+ .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+ .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ .. I SAVE D
+ ... S NFOUND=NFOUND+1
+ ... S IPLIST(CONVAL,DFN,NFOUND,FILENUM)=TEMP_U_VALUE
+ . M ^TMP($J,PLIST)=IPLIST
+ K ^TMP($J,"HLOCL"),^TMP($J,TGLIST)
+ Q
+ ;
+ ;=============================================
+PCSTOPL ;Print the Clinic Stop list. Called by the print template PXRM
+ ;LOCATION LIST INQUIRY.
+ N AMIS,CSTOP,IND,JND,SKIP,TEMP
+ S (IND,SKIP)=0
+ F  S IND=+$O(^PXRMD(810.9,D0,40.7,IND)) Q:IND=0  D
+ . S TEMP=^PXRMD(810.9,D0,40.7,IND,0)
+ . S CSTOP=$P(TEMP,U,1)
+ .; DBIA #557
+ . S CSTOP=$P(^DIC(40.7,CSTOP,0),U,1)
+ . S AMIS=$P(TEMP,U,2)
+ . I SKIP W ! S SKIP=0
+ . W !,?2,CSTOP,?34,AMIS
+ . I '$D(^PXRMD(810.9,D0,40.7,IND,1)) Q
+ . S SKIP=1
+ . W !,?4,"Credit Stops to Exclude:"
+ . S JND=0
+ . F  S JND=+$O(^PXRMD(810.9,D0,40.7,IND,1,JND)) Q:JND=0  D
+ .. S TEMP=^PXRMD(810.9,D0,40.7,IND,1,JND,0)
+ .. S TEMP=$P(^DIC(40.7,TEMP,0),U,1,2)
+ .. S CSTOP=$P(TEMP,U,1)
+ .. S AMIS=$P(TEMP,U,2)
+ .. W !,?6,CSTOP,?38,AMIS
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m

@@ -1 @@
-PXRMLPAU        ; SLC/AGP - Reminder Patient List ;09/06/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM PATIENT LIST
-START(IEN)      ;
-        N PXRMDONE,VALMBCK,VALMSG,X,XMZ
-        S X="IORESET"
-        S VALMCNT=0
-        D EN^VALM("PXRM PATIENT LIST AUTH USERS")
-        W IORESET
-        Q
-        ;
-BLDLIST ;
-        N PLIST,PIEN
-        K ^TMP("PXRMLPAU",$J)
-        K ^TMP("PXRMLPAH",$J)
-        D LIST(.PLIST,.PIEN)
-        I $D(PLIST)=0 G EXIT
-        M ^TMP("PXRMLPAU",$J)=PLIST
-        S VALMCNT=PLIST("VALMCNT")
-        F IND=1:1:VALMCNT D
-        .S ^TMP("PXRMLPAU",$J,"IDX",IND,IND)=PIEN(IND)
-        Q
-        ;
-LIST(RLIST,PIEN)        ;Build a list of patient list users.
-        N ACCESS,ARRAY,COUNT,DATE,DFN,IND,SIEN,FNAME,NAME,NODE,LEVEL
-        ;Build the list in alphabetical order.
-        S VALMCNT=0
-        S DFN=""
-        F  S DFN=$O(^PXRMXP(810.5,IEN,40,"B",DFN)) Q:DFN=""  D
-        .S IND=""
-        .F  S IND=$O(^PXRMXP(810.5,IEN,40,"B",DFN,IND)) Q:'IND  D
-        ..S ACCESS=$P($G(^PXRMXP(810.5,IEN,40,IND,0)),U,2)
-        ..S FNAME=$$GET1^DIQ(200,DFN,.01) Q:$G(FNAME)=""
-        ..S ARRAY(FNAME)=$G(IND)_U_$G(ACCESS)
-        I $D(ARRAY)=0 Q
-        S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
-        .S VALMCNT=VALMCNT+1
-        .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,$P($G(ARRAY(NAME)),U,2))
-        .S PIEN(VALMCNT)=$P($G(ARRAY(NAME)),U)
-        S RLIST("VALMCNT")=VALMCNT
-        Q
-        ;
-FRE(NUMBER,NAME,ACCESS) ;Format  entry number, name, source,
-        ;and date packed.
-        N TEMP,TNAME,TSOURCE
-        S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
-        S TNAME=$E(NAME,1,45)
-        S TEMP=TEMP_"  "_TNAME
-        S TEMP=$$LJ^XLFSTR(TEMP,40," ")_ACCESS
-        Q TEMP
-        ;
-ENTRY   ;Entry code
-        D BLDLIST,XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMLPAU",$J)
-        K ^TMP("PXRMLPAH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        Q
-        ;
-HDR     ; Header code
-        S VALMHDR(1)="Available Patient Lists."
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,SUB,XQORM
-        S SUB="PXRMLPAH"
-        D EN^VALM("PXRM PATIENT LIST HELP")
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-PEXIT   ;PXRM MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-ADD     ;add a user
-        N CREAT,CNT,DIC,DIE,FDA,MSG,USER,Y
-        S CREAT=$P($G(^PXRMXP(810.5,IEN,0)),U,7)
-        I $G(CREAT)'=DUZ D  G ADDE
-        . W !,"Only the creator of this list can add an user." H 2
-        D FULL^VALM1
-        S DIC="^VA(200,"
-        S DIC(0)="QAEB"
-        S DIC("A")="Select Users: "
-        D ^DIC
-        I Y=-1 Q
-        S USER=+Y
-        K Y
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="S^F:Full Control;V:View Only"
-        S DIR("A")="Select level of control: "
-        S DIR("B")="V"
-        S DIR("?")="Enter F or V. For detailed help type ??"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        I $G(Y)="" W !,"A level of control must be entered." H 2 Q
-        S YESNO=$E(Y(0))
-        S FDA(810.54,"+2,"_IEN_",",.01)=USER
-        S FDA(810.54,"+2,"_IEN_",",1)=Y
-        D UPDATE^DIE("","FDA","","MSG")
-        I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
-ADDE    ;
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-XQORM   ;
-        S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST AUTH USER SELECT",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
-XSEL    ;PXRM SELECT COMPONENT validation
-        N EPIEN,LISTIEN,LRIEN,SEL
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;Get the patient list ien
-        S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",SEL,SEL)
-        ;Full screen mode
-        D FULL^VALM1
-        D PDELETE
-        ;
-        ;Option to Install, Delete or Install History
-        ;
-        S VALMBCK="R"
-        Q
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Select CO to copy the patient list.\\"
-        .S HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
-        .S HTEXT(3)="Select DE to delete the patient list.\\"
-        .S HTEXT(4)="Select DSP to display the patient list.\\"
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-PDELETE ;Patient list delete
-        ;
-        ;Full Screen
-        W IORESET
-        ;
-        N CREAT,IND,LISTIEN,NODE
-        I DUZ'=$P($G(^PXRMXP(810.5,IEN,0)),U,7) D  G PDELEX
-        .W !,"Only the creator of this list can delete it." H 2
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) D BLDLIST S VALMBCK="R" Q
-        S IND="",PXRMDONE=0
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the patient list ien.
-        .S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",IND,IND)
-        .S DA(1)=IEN,DA=LISTIEN,DIK="^PXRMXP(810.5,"_DA(1)_",40," D ^DIK
-        .W !,"Patient list deleted"
-        ;
-PDELEX  ;
-        D BLDLIST
-        ;
-        S VALMBCK="R"
-        Q
-        ;
+PXRMLPAU ; SLC/AGP - Reminder Patient List ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;Main entry point for PXRM PATIENT LIST
+START(IEN) ;
+ N PXRMDONE,VALMBCK,VALMSG,X,XMZ
+ S X="IORESET"
+ S VALMCNT=0
+ D EN^VALM("PXRM PATIENT LIST AUTH USERS")
+ W IORESET
+ Q
+ ;
+BLDLIST ;
+ N PLIST,PIEN
+ K ^TMP("PXRMLPAU",$J)
+ K ^TMP("PXRMLPAH",$J)
+ D LIST(.PLIST,.PIEN)
+ I $D(PLIST)=0 G EXIT
+ M ^TMP("PXRMLPAU",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMLPAU",$J,"IDX",IND,IND)=PIEN(IND)
+ Q
+ ;
+LIST(RLIST,PIEN) ;Build a list of patient list users.
+ N ACCESS,ARRAY,COUNT,DATE,DFN,IND,SIEN,FNAME,NAME,NODE,LEVEL
+ ;Build the list in alphabetical order.
+ S VALMCNT=0
+ S DFN=""
+ F  S DFN=$O(^PXRMXP(810.5,IEN,40,"B",DFN)) Q:DFN=""  D
+ .S IND=""
+ .F  S IND=$O(^PXRMXP(810.5,IEN,40,"B",DFN,IND)) Q:'IND  D
+ ..S ACCESS=$P($G(^PXRMXP(810.5,IEN,40,IND,0)),U,2)
+ ..S FNAME=$$GET1^DIQ(200,DFN,.01) Q:$G(FNAME)=""
+ ..S ARRAY(FNAME)=$G(IND)_U_$G(ACCESS)
+ I $D(ARRAY)=0 Q
+ S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
+ .S VALMCNT=VALMCNT+1
+ .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,$P($G(ARRAY(NAME)),U,2))
+ .S PIEN(VALMCNT)=$P($G(ARRAY(NAME)),U)
+ S RLIST("VALMCNT")=VALMCNT
+ Q
+ ;
+FRE(NUMBER,NAME,ACCESS) ;Format  entry number, name, source,
+ ;and date packed.
+ N TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,45)
+ S TEMP=TEMP_"  "_TNAME
+ S TEMP=$$LJ^XLFSTR(TEMP,40," ")_ACCESS
+ Q TEMP
+ ;
+ENTRY ;Entry code
+ D BLDLIST,XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMLPAU",$J)
+ K ^TMP("PXRMLPAH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ Q
+ ;
+HDR ; Header code
+ S VALMHDR(1)="Available Patient Lists."
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMLPAH"
+ D EN^VALM("PXRM PATIENT LIST HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+PEXIT ;PXRM MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+ADD ;add a users
+ N CREAT,CNT,DIC,DIE,FDA,MSG,USER,Y
+ S CREAT=$P($G(^PXRMXP(810.5,IEN,0)),U,7)
+ I $G(CREAT)'=DUZ D  G ADDE
+ . W !,"Only the creator of this list can add an user." H 2
+ D FULL^VALM1
+ S DIC="^VA(200,"
+ S DIC(0)="QAEB"
+ S DIC("A")="Select Users: "
+ D ^DIC
+ I Y=-1 Q
+ S USER=+Y
+ K Y
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="S^F:Full Control;V:View Only"
+ S DIR("A")="Select level of control: "
+ S DIR("B")="V"
+ S DIR("?")="Enter F or V. For detailed help type ??"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ I $G(Y)="" W !,"A status must be enter" H 2 Q
+ S YESNO=$E(Y(0))
+ S FDA(810.54,"+2,"_IEN_",",.01)=USER
+ S FDA(810.54,"+2,"_IEN_",",1)=Y
+ D UPDATE^DIE("","FDA","","MSG")
+ I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
+ADDE ;
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+XQORM ;
+ S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST AUTH USER SELECT",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM SELECT COMPONENT validation
+ N EPIEN,LISTIEN,LRIEN,SEL
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;Get the patient list ien
+ S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",SEL,SEL)
+ ;Full screen mode
+ D FULL^VALM1
+ D PDELETE
+ ;
+ ;Option to Install, Delete or Install History
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="Select CO to copy patient list."
+ .S HTEXT(2)="Select COE to copy patient list to OE/RR Team."
+ .S HTEXT(3)="Select CR to delete patient list."
+ .S HTEXT(4)="Select DSP to display patient list."
+ ;
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+PDELETE ;Patient list delete
+ ;
+ ;Full Screen
+ W IORESET
+ ;
+ N CREAT,IND,LISTIEN,NODE
+ I DUZ'=$P($G(^PXRMXP(810.5,IEN,0)),U,7) D  G PDELEX
+ .W !,"Only the creator of this list can delete an user." H 2
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) D BLDLIST S VALMBCK="R" Q
+ S IND="",PXRMDONE=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the patient list ien.
+ .S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",IND,IND)
+ .S DA(1)=IEN,DA=LISTIEN,DIK="^PXRMXP(810.5,"_DA(1)_",40," D ^DIK
+ .W !,"PATIENT DELETED"
+ ;
+PDELEX ;
+ D BLDLIST
+ ;
+ S VALMBCK="R"
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m

@@ -1 @@
-PXRMLPHS        ; SLC/PJH,PKR - Run Health Summaries from Patient List ;03/26/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ;External Ref DBIA #398
-        ;
-HSA(LISTIEN)    ;Run health summary for all patients on this patient list.
-        N HSIEN,PLNODE
-        ;Initialise
-        D FULL^VALM1
-        ;Reset screen mode
-        W IORESET
-        ;
-        ;Select Health Summary
-        D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT)
-        ;
-        S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT
-        K ^XTMP(PLNODE)
-        S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST"
-        D SORT(LISTIEN,PLNODE)
-        D QUE(HSIEN,PLNODE)
-        Q
-        ;
-HSEL(IEN)       ;Select Health Summary Type
-        N X,Y,DIC
-HS1     S DIC=142,DIC(0)="QAEMZ"
-        S DIC("A")="Select HEALTH SUMMARY TYPE: "
-        W !
-        D ^DIC
-        I X="" W !,"A health summary type name must be entered" G HS1
-        I X=(U_U) S DTOUT=1
-        I Y=-1 S DUOUT=1
-        I $D(DTOUT)!$D(DUOUT) Q
-        ;Return HS ien
-        S IEN=$P(Y,U)
-        Q
-        ;
-HSI(PLNODE)     ;Print health summary for selected patients.
-        N HSIEN
-        ;Initialise
-        D FULL^VALM1
-        ;Reset screen mode
-        W IORESET
-        ;
-        ;Select Health Summary
-        D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT)
-        D QUE(HSIEN,PLNODE)
-        Q
-        ;
-PRINT(HSIEN,PLNODE)     ;Print HS for Patient List IEN
-        N DFN,DIROUT,SUB
-        ;Print HS for each patient
-        S SUB=0
-        F  S SUB=$O(^XTMP(PLNODE,SUB)) Q:(SUB="")!$D(DIROUT)  D
-        .S DFN=^XTMP(PLNODE,SUB)
-        .D ENX^GMTSDVR(DFN,HSIEN,"","") ; DBIA #398
-        ;
-        ;Clear workfile
-        K ^XTMP(PLNODE)
-        Q
-        ;
-QUE(HSIEN,PLNODE)       ;Determine whether the report should be queued.
-        N PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE
-        S %ZIS="M"
-        S ZTDESC="Patient List Health Summaries - print"
-        S ZTRTN="PRINT^PXRMLPHS(HSIEN,PLNODE)"
-        S ZTSAVE("HSIEN")=""
-        S ZTSAVE("PLNODE")=""
-        S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,1)
-        S VALMBCK="R"
-        Q
-        ;
-SORT(LISTIEN,PLNODE)    ;Sort workfile as required
-        N DATA,DFN,IND,PNAME
-        ;Build the list in alphabetical order.
-        S IND=0
-        F  S IND=$O(^PXRMXP(810.5,LISTIEN,30,IND)) Q:'IND  D
-        .S DATA=$G(^PXRMXP(810.5,LISTIEN,30,IND,0)) Q:DATA=""
-        .S DFN=$P(DATA,U) Q:'DFN
-        .;DBIA #10035
-        .S PNAME=$P(^DPT(DFN,0),U,1) Q:PNAME=""
-        .S ^XTMP(PLNODE,PNAME)=DFN
-        Q
-        ;
+PXRMLPHS ; SLC/PJH,PKR - Run Health Summaries from Patient List ;08/08/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ;External Ref DBIA #398
+ ;
+HSA(LISTIEN) ;Run health summary for all patients on this patient list.
+ N HSIEN,PLNODE
+ ;Initialise
+ D FULL^VALM1
+ ;Reset screen mode
+ W IORESET
+ ;
+ ;Select Health Summary
+ D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT)
+ ;
+ S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT
+ K ^XTMP(PLNODE)
+ S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST"
+ D SORT(LISTIEN,PLNODE)
+ D QUE(HSIEN,PLNODE)
+ Q
+ ;
+HSEL(IEN) ;Select Health Summary Type
+ N X,Y,DIC
+HS1 S DIC=142,DIC(0)="QAEMZ"
+ S DIC("A")="Select HEALTH SUMMARY TYPE: "
+ W !
+ D ^DIC
+ I X="" W !,"A health summary type name must be entered" G HS1
+ I X=(U_U) S DTOUT=1
+ I Y=-1 S DUOUT=1
+ I $D(DTOUT)!$D(DUOUT) Q
+ ;Return HS ien
+ S IEN=$P(Y,U)
+ Q
+ ;
+HSI(PLNODE) ;Print health summary for selected patients.
+ N HSIEN
+ ;Initialise
+ D FULL^VALM1
+ ;Reset screen mode
+ W IORESET
+ ;
+ ;Select Health Summary
+ D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT)
+ D QUE(HSIEN,PLNODE)
+ Q
+ ;
+PRINT(HSIEN,PLNODE) ;Print HS for Patient List IEN
+ N DFN,DIROUT,SUB
+ ;Print HS for each patient
+ S SUB=0
+ F  S SUB=$O(^XTMP(PLNODE,SUB)) Q:(SUB="")!$D(DIROUT)  D
+ .S DFN=^XTMP(PLNODE,SUB)
+ .D ENX^GMTSDVR(DFN,HSIEN,"","") ; DBIA #398
+ ;
+ ;Clear workfile
+ K ^XTMP(PLNODE)
+ Q
+ ;
+QUE(HSIEN,PLNODE) ;Determine whether the report should be queued.
+ N PXRMQUE,RETZTSK,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE
+ S %ZIS="M"
+ S ZTDESC="Patient List Health Summaries - print"
+ S ZTRTN="PRINT^PXRMLPHS(HSIEN,PLNODE)"
+ S ZTSAVE("HSIEN")=""
+ S ZTSAVE("PLNODE")=""
+ S RETZTSK=1
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.RETZTSK)
+ S VALMBCK="R"
+ Q
+ ;
+SORT(LISTIEN,PLNODE) ;Sort workfile as required
+ N DATA,DFN,IND,PNAME
+ ;Build the list in alphabetical order.
+ S IND=0
+ F  S IND=$O(^PXRMXP(810.5,LISTIEN,30,IND)) Q:'IND  D
+ .S DATA=$G(^PXRMXP(810.5,LISTIEN,30,IND,0)) Q:DATA=""
+ .S DFN=$P(DATA,U) Q:'DFN
+ .;DBIA #10035
+ .S PNAME=$P(^DPT(DFN,0),U,1) Q:PNAME=""
+ .S ^XTMP(PLNODE,PNAME)=DFN
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m

@@ -1 @@
-PXRMLPP ; SLC/PKR/PJH - Reminder Patient List Patients ;04/04/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM PATIENT LIST
-START(IEN)      ;
-        N CDATE,CLASS,CREATOR,INDP,INTP,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE
-        N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
-        ;Get Patient List record and associated data.
-        S LDATA=$G(^PXRMXP(810.5,IEN,0))
-        S LNAME=$P(LDATA,U,1)
-        S CDATE=$P(LDATA,U,4)
-        S SOURCE=$P(LDATA,U,5),SNAME=""
-        ;Check if generated from #810.2
-        I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U)
-        ;If not check if generated from #810.4
-        I SNAME="" D
-        . S SOURCE=$P(LDATA,U,6)
-        . I SOURCE'="" S SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U)
-        ;If still no source check for created from Reminder Due Report.
-        I SNAME="" D
-        . S SOURCE=$P(LDATA,U,9)
-        . I SOURCE'="" S SNAME="Reminder Due Report"
-        ;If there still is no source then assume it was generated in the
-        ;past by a Reminder Due Report.
-        I SNAME="" S SNAME="Reminder Due Report"
-        ;Creator
-        S CREATOR=+$P(LDATA,U,7)
-        S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None")
-        ;Type
-        S TYPE=$P(LDATA,U,8)
-        S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM)
-        ;Class
-        S CLASS=$P($G(^PXRMXP(810.5,IEN,100)),U)
-        S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local")
-        S INDP=$P(LDATA,U,11)
-        S INTP=$P(LDATA,U,12)
-        ;Default view by name.
-        S PXRMVIEW="N"
-        S VALMCNT=0
-        D EN^VALM("PXRM PATIENT LIST PATIENTS")
-        Q
-        ;
-BLDLIST(IEN)    ;Build a list of all patients
-        N IND,INCINST
-        S INCINST=+$P(^PXRMXP(810.5,IEN,0),U,10)
-        I 'INCINST D CHGCAP^VALM("HEADER3","")
-        K ^TMP("PXRMLPP",$J),^TMP("PXRMLPPA",$J),^TMP("PXRMLPPI",$J)
-        D LIST(.VALMCNT,.IEN,INCINST)
-        F IND=1:1:VALMCNT D
-        .S ^TMP("PXRMLPP",$J,"IDX",IND,IND)=^TMP("PXRMLPPI",$J,IND)
-        K ^TMP("PXRMLPPI",$J)
-        Q
-DEM     ;
-        D FULL^VALM1
-        D EN^PXRMPDR(IEN)
-        S VALMBCK="R"
-        Q
-        ;
-EDIT    ;Edit selected patient list fields.
-        N DA,DIE,DR,TEMP
-        S DA=IEN,DIE="^PXRMXP(810.5,"
-        S DR=".01;.08"
-        I $D(^XUSEC("PXRM MANAGER",DUZ)) S DR=DR_";.07"
-        D ^DIE
-        S TEMP=^PXRMXP(810.5,IEN,0)
-        S LNAME=$P(TEMP,U,1),CREATOR=$P(TEMP,U,7),TYPE=$P(TEMP,U,8)
-        S CREATOR=$P(^VA(200,CREATOR,0),U,1)
-        D HDR^PXRMLPP
-        S VALMBCK="R"
-        Q
-        ;
-EDITOK(IEN)     ;Screen for protocol PXRM PATIENT LIST EDIT, return true if
-        ;the user is permitted to edit the selected patient list.
-        I $D(^XUSEC("PXRM MANAGER",DUZ)) Q 1
-        N CREATOR
-        S CREATOR=$P(^PXRMXP(810.5,IEN,0),U,7)
-        Q $S(CREATOR=DUZ:1,1:0)
-        ;
-ENTRY   ;Entry code
-        D BLDLIST(IEN)
-        D XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMLPP",$J)
-        K ^TMP("PXRMLPPH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="R"
-        Q
-        ;
-FRE(NUMBER,PNAME,DFN,DECEASED,TESTP,INST)       ;Format  entry number, name, primary
-        ;station and deceased, test information.
-        N TEMP,TEXT,TNAME,TSOURCE
-        S TEXT=$$RJ^XLFSTR(NUMBER,5," ")
-        S TEXT=$$SETFLD^VALM1(PNAME,TEXT,"HEADER1")
-        S TEXT=TEXT_"  "_$$LJ^XLFSTR(DFN,15," ")
-        S TEMP=""
-        I DECEASED S TEMP=" (D)"
-        I TESTP S TEMP=" (T)"
-        I DECEASED,TESTP S TEMP=" (DP)"
-        S TEXT=TEXT_TEMP
-        I INST'="" S TEXT=$$SETFLD^VALM1(INST,TEXT,"HEADER3")
-        Q TEXT
-        ;
-HDR     ; Header code
-        N TEXT
-        S VALMHDR(1)="List Name: "_LNAME
-        S VALMHDR(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z")
-        S VALMHDR(2)=$$LJ^XLFSTR(VALMHDR(2),40)_"Creator: "_CREATOR
-        S VALMHDR(3)=" Class: "_CLASS
-        S VALMHDR(3)=$$LJ^XLFSTR(VALMHDR(3),40)_"Type: "_TYPE
-        S VALMHDR(4)=" Source: "_SNAME
-        S VALMHDR(5)=" Number of patients: "_VALMCNT
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        S TEXT=""
-        I INDP S TEXT=" (D=deceased)"
-        I INTP S TEXT=" (T=test)"
-        I INDP,INTP S TEXT=" (D=deceased, T=test)"
-        S TEXT="DFN"_TEXT
-        D CHGCAP^VALM("HEADER2",TEXT)
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,SUB,XQORM
-        S SUB="PXRMLPPH"
-        D EN^VALM("PXRM PATIENT LIST HELP")
-        Q
-HSA     ;Print Health Summary for all patients on list
-        D HSA^PXRMLPHS(IEN)
-        S VALMBCK="R"
-        Q
-        ;
-HSI     ;Print Health Summary for selected patients.
-        ;Full Screen
-        W IORESET
-        N IND,DFN,PLNODE,PNAME,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT
-        K ^XTMP(PLNODE)
-        S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST"
-        S IND="",PXRMDONE=0
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the patient list ien.
-        .S DFN=^TMP("PXRMLPP",$J,"IDX",IND,IND)
-        .;DBIA #10035
-        .S PNAME=$P(^DPT(DFN,0),U,1)
-        .I PNAME="" S PNAME=DFN_" does not exist"
-        .S ^XTMP(PLNODE,PNAME)=DFN
-        D HSI^PXRMLPHS(PLNODE)
-        S VALMBCK="R"
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-LIST(VALMCNT,IEN,INCINST)       ;Build a list of patients.
-        N DATA,DECEASED,DFN,IND,INST,NEXT,PNAME,SUB,TESTP
-        ;Build the ordered list.
-        S IND=0,SUB="NAME"
-        F  S IND=$O(^PXRMXP(810.5,IEN,30,IND)) Q:'IND  D
-        .S DATA=$G(^PXRMXP(810.5,IEN,30,IND,0)) Q:DATA=""
-        .S DFN=$P(DATA,U) Q:'DFN
-        .S DECEASED=$P(DATA,U,4)
-        .S TESTP=$P(DATA,U,5)
-        .;#DBIA 10035
-        .S PNAME=$P($G(^DPT(DFN,0)),U,1)
-        .I PNAME="" S PNAME=DFN_" does not exist"
-        .S INSTNUM=$P(DATA,U,2) S:INSTNUM="" INSTNUM="NONE"
-        .S INST=$P(DATA,U,3)
-        .;Lists built before PXRM*2*4 will only have the Institution ien.
-        .I INST="" S INST=$P(DATA,U,2)
-        .I INST="" S INST="NONE"
-        .I PXRMVIEW="I" S SUB=INST
-        .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=DECEASED_U_TESTP_U_INST
-        ;Transfer to list manager array 
-        S SUB="",VALMCNT=0
-        F  S SUB=$O(^TMP("PXRMLPPA",$J,SUB)) Q:SUB=""  D
-        .S (INST,PNAME)=""
-        .F  S PNAME=$O(^TMP("PXRMLPPA",$J,SUB,PNAME)) Q:PNAME=""  D
-        ..S DFN=""
-        ..F  S DFN=$O(^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)) Q:DFN=""  D
-        ...S DATA=^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)
-        ...S DECEASED=$P(DATA,U,1)
-        ...S TESTP=$P(DATA,U,2)
-        ...I INCINST S INST=$P(DATA,U,3)
-        ...S VALMCNT=VALMCNT+1
-        ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,DFN,DECEASED,TESTP,INST)
-        ...S ^TMP("PXRMLPPI",$J,VALMCNT)=DFN
-        K ^TMP("PXRMLPPA",$J)
-        Q
-        ;
-PEXIT   ;PXRM PATIENT LIST PATIENTS MENU protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        D XQORM
-        Q
-        ;
-USER    ;
-        I $P($G(^PXRMXP(810.5,IEN,0)),U,8)="PUB" D FULL^VALM1 W !,"This option is locked for Public Lists." H 2 Q
-        D FULL^VALM1
-        D START^PXRMLPAU(IEN)
-        S VALMBCK="R"
-        Q
-        ;
-USR(IEN)        ;Screen for protocol PXRM PATIENT LIST AUTH USER
-        N TYPE
-        S TYPE=$P(^PXRMXP(810.5,IEN,0),U,8)
-        ;Public lists cannot have individual user access.
-        I TYPE="PUB" Q "N"
-        Q $$ACCESS^PXRMLPU(IEN)
-        ;
-VIEW    ;Select view
-        W IORESET
-        S VALMBCK="R",VALMBG=1
-        N X,Y,CODE,DIR
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="S"_U_"I:Sort by Institution and Name;"
-        S DIR(0)=DIR(0)_"N:Sort by Name;"
-        S DIR("A")="TYPE OF VIEW"
-        S DIR("B")=$S(PXRMVIEW="N":"I",1:"N")
-        S DIR("?")="Select from the codes displayed."
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        ;Change display type
-        S PXRMVIEW=Y
-        ;Rebuild Workfile
-        D BLDLIST^PXRMLPP(IEN),HDR
-        Q
-        ;
-XSEL    ;PXRM PATIENT LIST PATIENT SELECT validation
-        N EPIEN,DFN,SEL
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;
-        ;Get the patient list ien
-        S DFN=^TMP("PXRMLPP",$J,"IDX",SEL,SEL)
-        ;Full screen mode
-        D FULL^VALM1
-        ;Print individual Health Summary
-        D HSI^PXRMLPHS(DFN)
-        S VALMBCK="R"
-        Q
-        ;
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST PATIENT SELECT",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
+PXRMLPP ; SLC/PKR/PJH - Reminder Patient List Patients ;01/06/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM PATIENT LIST
+START(IEN) ;
+ N CDATE,CLASS,CREATOR,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE
+ N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+ ;Get Patient List record and associated data.
+ S LDATA=$G(^PXRMXP(810.5,IEN,0))
+ S LNAME=$P(LDATA,U,1)
+ S CDATE=$P(LDATA,U,4)
+ S SOURCE=$P(LDATA,U,5),SNAME=""
+ ;Check if generated from #810.2
+ I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U)
+ ;If not check if generated from #810.4
+ I SNAME="" D
+ . S SOURCE=$P(LDATA,U,6)
+ . I SOURCE'="" S SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U)
+ ;If still no source check for created from Reminder Due Report.
+ I SNAME="" D
+ . S SOURCE=$P(LDATA,U,9)
+ . I SOURCE'="" S SNAME="Reminder Due Report"
+ ;If there still is no source then assume it was generated in the
+ ;past by a Reminder Due Report.
+ I SNAME="" S SNAME="Reminder Due Report"
+ ;Creator
+ S CREATOR=+$P(LDATA,U,7)
+ S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None")
+ ;Type
+ S TYPE=$P(LDATA,U,8)
+ S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM)
+ ;Class
+ S CLASS=$P($G(^PXRMXP(810.5,IEN,100)),U)
+ S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local")
+ ;Default view by name.
+ S PXRMVIEW="N"
+ S VALMCNT=0
+ D EN^VALM("PXRM PATIENT LIST PATIENTS")
+ Q
+ ;
+BLDLIST(IEN) ;Build a list of all patients
+ N IND,INCINST
+ S INCINST=+$P(^PXRMXP(810.5,IEN,0),U,10)
+ I 'INCINST D CHGCAP^VALM("HEADER3","")
+ K ^TMP("PXRMLPP",$J),^TMP("PXRMLPPA",$J),^TMP("PXRMLPPI",$J)
+ D LIST(.VALMCNT,.IEN,INCINST)
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMLPP",$J,"IDX",IND,IND)=^TMP("PXRMLPPI",$J,IND)
+ K ^TMP("PXRMLPPI",$J)
+ Q
+DEM ;
+ D FULL^VALM1
+ D EN^PXRMPDR(IEN)
+ S VALMBCK="R"
+ Q
+ ;
+EDIT ;Edit selected patient list fields.
+ N DA,DIE,DR,TEMP
+ S DA=IEN,DIE="^PXRMXP(810.5,"
+ S DR=".01;.08"
+ I $D(^XUSEC("PXRM MANAGER",DUZ)) S DR=DR_";.07"
+ D ^DIE
+ S TEMP=^PXRMXP(810.5,IEN,0)
+ S LNAME=$P(TEMP,U,1),CREATOR=$P(TEMP,U,7),TYPE=$P(TEMP,U,8)
+ S CREATOR=$P(^VA(200,CREATOR,0),U,1)
+ D HDR^PXRMLPP
+ S VALMBCK="R"
+ Q
+ ;
+EDITOK(IEN) ;Screen for protocol PXRM PATIENT LIST EDIT, return true if
+ ;the user is permitted to edit the selected patient list.
+ I $D(^XUSEC("PXRM MANAGER",DUZ)) Q 1
+ N CREATOR
+ S CREATOR=$P(^PXRMXP(810.5,IEN,0),U,7)
+ Q $S(CREATOR=DUZ:1,1:0)
+ ;
+ENTRY ;Entry code
+ D BLDLIST(IEN)
+ D XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMLPP",$J)
+ K ^TMP("PXRMLPPH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="R"
+ Q
+ ;
+FRE(NUMBER,NAME,INST,DFN) ;Format  entry number, name and primary station
+ N TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,30)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,32," ")
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DFN,15," ")
+ I INST'="" S TEMP=TEMP_"  "_INST
+ Q TEMP
+ ;
+HDR ; Header code
+ S VALMHDR(1)="List Name: "_LNAME_" ("_VALMCNT_" patients)"
+ S VALMHDR(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z")
+ S VALMHDR(2)=$$LJ^XLFSTR(VALMHDR(2),40)_"Creator: "_CREATOR
+ S VALMHDR(3)=" Class: "_CLASS
+ S VALMHDR(3)=$$LJ^XLFSTR(VALMHDR(3),40)_"Type: "_TYPE
+ S VALMHDR(4)=" Source: "_SNAME
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMLPPH"
+ D EN^VALM("PXRM PATIENT LIST HELP")
+ Q
+HSA ;Print Health Summary for all patients on list
+ D HSA^PXRMLPHS(IEN)
+ S VALMBCK="R"
+ Q
+ ;
+HSI ;Print Health Summary for selected patients.
+ ;Full Screen
+ W IORESET
+ N IND,DFN,PLNODE,PNAME,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT
+ K ^XTMP(PLNODE)
+ S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST"
+ S IND="",PXRMDONE=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the patient list ien.
+ .S DFN=^TMP("PXRMLPP",$J,"IDX",IND,IND)
+ .;DBIA #10035
+ .S PNAME=$P(^DPT(DFN,0),U,1)
+ .S ^XTMP(PLNODE,PNAME)=DFN
+ D HSI^PXRMLPHS(PLNODE)
+ S VALMBCK="R"
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+LIST(VALMCNT,IEN,INCINST) ;Build a list of patients.
+ N DATA,DFN,IND,INST,NEXT,PNAME,SUB
+ ;Build the ordered list.
+ S IND=0,SUB="NAME"
+ F  S IND=$O(^PXRMXP(810.5,IEN,30,IND)) Q:'IND  D
+ .S DATA=$G(^PXRMXP(810.5,IEN,30,IND,0)) Q:DATA=""
+ .S DFN=$P(DATA,U) Q:'DFN
+ .;#DBIA 10035
+ .S PNAME=$P($G(^DPT(DFN,0)),U,1)
+ .S INSTNUM=$P(DATA,U,2) S:INSTNUM="" INSTNUM="NONE"
+ .S INST=$P(DATA,U,3)
+ .;Lists built before PXRM*2*4 will only have the Institution ien.
+ .I INST="" S INST=$P(DATA,U,2)
+ .I INST="" S INST="NONE"
+ .I PXRMVIEW="I" S SUB=INST
+ .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=INST
+ ;Transfer to list manager array 
+ S SUB="",VALMCNT=0
+ F  S SUB=$O(^TMP("PXRMLPPA",$J,SUB)) Q:SUB=""  D
+ .S (INST,PNAME)=""
+ .F  S PNAME=$O(^TMP("PXRMLPPA",$J,SUB,PNAME)) Q:PNAME=""  D
+ ..S DFN=""
+ ..F  S DFN=$O(^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)) Q:DFN=""  D
+ ...I INCINST S INST=^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)
+ ...S VALMCNT=VALMCNT+1
+ ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,INST,DFN)
+ ...S ^TMP("PXRMLPPI",$J,VALMCNT)=DFN
+ K ^TMP("PXRMLPPA",$J)
+ Q
+ ;
+PEXIT ;PXRM PATIENT LIST PATIENTS MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ D XQORM
+ Q
+ ;
+USER ;
+ I $P($G(^PXRMXP(810.5,IEN,0)),U,8)="PUB" D FULL^VALM1 W !,"This option is locked for Public Lists." H 2 Q
+ D FULL^VALM1
+ D START^PXRMLPAU(IEN)
+ S VALMBCK="R"
+ Q
+ ;
+USR(IEN) ;Screen for protocol PXRM PATIENT LIST AUTH USER
+ N TYPE
+ S TYPE=$P(^PXRMXP(810.5,IEN,0),U,8)
+ ;Public lists cannot have individual user access.
+ I TYPE="PUB" Q "N"
+ Q $$ACCESS^PXRMLPU(IEN)
+ ;
+VIEW ;Select view
+ W IORESET
+ S VALMBCK="R",VALMBG=1
+ N X,Y,CODE,DIR
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="S"_U_"I:Sort by Institution and Name;"
+ S DIR(0)=DIR(0)_"N:Sort by Name;"
+ S DIR("A")="TYPE OF VIEW"
+ S DIR("B")=$S(PXRMVIEW="N":"I",1:"N")
+ S DIR("?")="Select from the codes displayed."
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ ;Change display type
+ S PXRMVIEW=Y
+ ;Rebuild Workfile
+ D BLDLIST^PXRMLPP(IEN),HDR
+ Q
+ ;
+XSEL ;PXRM PATIENT LIST PATIENT SELECT validation
+ N EPIEN,DFN,SEL
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the patient list ien
+ S DFN=^TMP("PXRMLPP",$J,"IDX",SEL,SEL)
+ ;Full screen mode
+ D FULL^VALM1
+ ;Print individual Health Summary
+ D HSI^PXRMLPHS(DFN)
+ S VALMBCK="R"
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST PATIENT SELECT",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m

@@ -1 @@
-PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;10/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM PATIENT LIST
-START(MODE)     ;
-        N PXRMDONE,VALMBCK,VALMSG,X,XMZ,MODE1
-        S X="IORESET"
-        D ENDR^%ZISS
-        S VALMCNT=0
-        D EN^VALM("PXRM PATIENT LIST USER")
-        W IORESET
-        D KILL^%ZISS
-        Q
-        ;
-ACCESS(IEN,NODE)        ;
-        ;Holders of the PXRM MANAGER key have full access to all lists.
-        ;DBIA #10076
-        I $D(^XUSEC("PXRM MANAGER",DUZ)) Q "F"
-        N ACCESS,TYPE
-        I $G(NODE)="" S NODE=$G(^PXRMXP(810.5,IEN,0))
-        S TYPE=$P(NODE,U,8)
-        I TYPE="" Q "F"
-        I TYPE="PUB" Q "F"
-        I $P(NODE,U,7)=DUZ Q "F"
-        S ACCESS="N"
-        I TYPE="PVT",$D(^PXRMXP(810.5,IEN,40,"B",DUZ)) D
-        . N USIEN,STATUS
-        . S USIEN=$O(^PXRMXP(810.5,IEN,40,"B",DUZ,""))
-        . S ACCESS=$S(USIEN="":"N",1:$P(^PXRMXP(810.5,IEN,40,USIEN,0),U,2))
-        Q ACCESS
-        ;
-BLDLIST ;
-        N PLIST
-        K ^TMP("PXRMLPU",$J)
-        K ^TMP("PXRMLPUH",$J)
-        S PLIST="PXRMLPU"
-        D LIST(MODE,PLIST)
-        S VALMCNT=+$G(^TMP("PXRMLPU",$J,"VALMCNT"))
-        Q
-        ;
-ENTRY   ;Entry code
-        ;MODE=0 ORDER BY NAME
-        ;MODE=1 ORDER BY TYPE
-        I $G(MODE)'>0 S MODE=0
-        D BLDLIST,XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMLPU",$J)
-        K ^TMP("PXRMLPUH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="R"
-        Q
-        ;
-HDR     ; Header code
-        N NAME
-        S VALMHDR(1)="Available Patient Lists."
-        Q
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Select CO to copy the patient list.\\"
-        .S HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
-        .S HTEXT(3)="Select DE to delete the patient list.\\"
-        .S HTEXT(4)="Select DCD to display creation documentation.\\"
-        .S HTEXT(5)="Select DSP to display the patient list.\\"
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,SUB,XQORM
-        S SUB="PXRMLPUH"
-        D EN^VALM("PXRM PATIENT LIST HELP")
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-LIST(MODE,PLIST)        ;Build a list of patient list entries.
-        N ACCESS,COUNT,DATA,DATE,IND,FMTSTR,FNAME,OUTPUT,NAME,NL,NUM
-        N STR,SUB,TYPE
-        S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLRRC")
-        ;MODE=0 build list in alphabetical order
-        ;MODE=1 build list by type of list.
-        K ^TMP($J,PLIST),^TMP(PLIST,$J)
-        S VALMCNT=0,NAME="",NUM=0,TYPE=""
-        F  S NAME=$O(^PXRMXP(810.5,"B",NAME)) Q:NAME=""  D
-        .S IND="" F  S IND=$O(^PXRMXP(810.5,"B",NAME,IND)) Q:'IND  D
-        ..S DATA=$G(^PXRMXP(810.5,IND,0))
-        ..S ACCESS=$$ACCESS(IND,DATA)
-        ..I ACCESS="N" Q
-        ..S FNAME=$P($G(DATA),U),DATE=$P($G(DATA),U,4)
-        ..S COUNT=+$P($G(^PXRMXP(810.5,IND,30,0)),U,4)
-        ..S TYPE=$P(DATA,U,8)
-        ..S SUB=$S(MODE=0:"NAME",1:TYPE)
-        ..S ^TMP($J,PLIST,SUB,FNAME)=IND_U_DATE_U_COUNT_U_TYPE_U_ACCESS
-        I '$D(^TMP($J,PLIST)) Q
-        ;Loop through ARRAY to populate the output list
-        ;sub is either the type of list or 'NAME'. If sort is
-        ;by TYPE show PVT lists first.
-        S SUB=""
-        F  S SUB=$O(^TMP($J,PLIST,SUB),-1) Q:SUB=""  D
-        . S FNAME=""
-        . F  S FNAME=$O(^TMP($J,PLIST,SUB,FNAME)) Q:FNAME=""  D
-        .. S DATA=^TMP($J,PLIST,SUB,FNAME),NUM=NUM+1
-        .. S ^TMP("PXRMLPU",$J,"SEL",NUM)=$P(DATA,U,1)
-        .. S DATE=$P(DATA,U,2),DATE=$$FMTE^XLFDT(DATE,2)
-        .. S $P(DATA,U,2)=DATE
-        .. S STR=NUM_U_FNAME_U_$P(DATA,U,2,5)
-        .. D COLFMT^PXRMTEXT(FMTSTR,STR," ",.NL,.OUTPUT)
-        .. F IND=1:1:NL D
-        ... S VALMCNT=VALMCNT+1,^TMP(PLIST,$J,VALMCNT,0)=OUTPUT(IND)
-        ... S ^TMP("PXRMLPU",$J,"IDX",VALMCNT,NUM)=""
-        S ^TMP(PLIST,$J,"VALMCNT")=VALMCNT
-        K ^TMP($J,PLIST)
-        Q
-        ;
-PCOPY   ;Patient list copy
-        S SUB="PXRMLPU"
-        D PCOPY1(SUB)
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-PCOPY1(SUB)     ;
-        ;Full Screen
-        W IORESET
-        N IND,LISTIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S IND="",PXRMDONE=0
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the patient list ien.
-        .S LISTIEN=^TMP(SUB,$J,"SEL",IND)
-        .D COPY^PXRMRUL1(LISTIEN)
-        Q
-        ;
-PDELETE ;Patient list delete
-        ;Full Screen
-        W IORESET
-        N DELOK,IND,LISTIEN,NODE,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S IND="",PXRMDONE=0
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the patient list ien.
-        .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
-        .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
-        .S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
-        .I DELOK D DELETE^PXRMRUL1(LISTIEN) Q
-        .E  D  Q
-        ..W !,"In order to delete a list you must be the creator or a Reminder Manager!"
-        ..S PXRMDONE=1 H 2
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-PEXIT   ;Protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-POERR   ;Patient list copy to OERR Team (#101.21)
-        ;Full Screen
-        W IORESET
-        N ACCESS,IND,LISTIEN,NODE,USIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S IND="",PXRMDONE=0
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the patient list ien.
-        .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
-        .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
-        .S ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE)
-        .I ACCESS="F" D OERR^PXRMLPOE(LISTIEN)
-        .I ACCESS="N" D
-        ..W !,"The list cannot be copied; you must have full access to copy the list to an OE/RR team!"
-        ..S PXRMDONE=1 H 2
-        S VALMBCK="R"
-        Q
-        ;
-PLIST   ;Patient list inquiry.
-        N CREAT,NAME,IND,LISTIEN,USIEN,VALMY,CREAT,NODE,TRUE
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        ;PXRMDONE is newed in PXRMLPU
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
-        .D START^PXRMLPP(LISTIEN)
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-VIEW    ;
-        D FULL^VALM1
-        N DIR,DTOUT,DUOUT,DIROUT,DIROUT,Y
-        S DIR(0)="SO^N:NAME;T:TYPE"
-        S DIR("A")="Select View Type"
-        D ^DIR
-        I $D(DTOUT),$D(DUOUT),$D(DIROUT) Q
-        I Y="N" S MODE=0 D ENTRY
-        I Y="T" S MODE=1 D ENTRY
-        Q
-        ;
-XQORM   ;
-        S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST USER SELECT ENTRY",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
-XSEL    ;SELECT validation
-        N EPIEN,LEVEL,LISTIEN,LRIEN,NODE,SEL
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;
-        ;Get the patient list ien
-        S LISTIEN=^TMP("PXRMLPU",$J,"SEL",SEL)
-        ;Get extract definition ien (if present)
-        S EPIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,5)
-        ;Get list rule ien
-        S LRIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,6)
-        S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
-        ;
-        ;Full screen mode
-        D FULL^VALM1
-        ;
-        ;Option to Install, Delete or Install History
-        N ACCESS,DELOK,DIR,OPTION,RIEN,X,Y
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S ACCESS=$$ACCESS(LISTIEN,NODE)
-        S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
-        S DIR(0)="SBM"_U_"CO:Copy Patient List;"
-        S DIR(0)=DIR(0)_"COE:Copy to OE/RR Team;"
-        I DELOK S DIR(0)=DIR(0)_"DE:Delete Patient List;"
-        S DIR(0)=DIR(0)_"DCD:Display Creation Documentation;"
-        S DIR(0)=DIR(0)_"DSP:Display Patient List;"
-        S DIR("A")="Select Action: "
-        S DIR("B")="DSP"
-        S DIR("?")="Select from the codes displayed. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMLPU(1)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
-        S OPTION=Y
-        ;
-        I $G(OPTION)="" G XSELE
-        ;
-        ;Copy patient list
-        I OPTION="CO" D COPY^PXRMRUL1(LISTIEN)
-        Q:$D(DUOUT)!$D(DTOUT)
-        ;
-        ;Copy to OE/RR Team
-        I OPTION="COE" D OERR^PXRMLPOE(LISTIEN)
-        Q:$D(DUOUT)!$D(DTOUT)
-        ;
-        ;Delete patient list
-        I OPTION="DE" D PDELETE
-        ;
-        ;Display creation documentation
-        I OPTION="DCD" D EN^PXRMLCD(LISTIEN)
-        ;
-        ;Display patient list
-        I OPTION="DSP" D START^PXRMLPP(LISTIEN)
-        ;
-XSELE   ;
-        D CLEAN^VALM10
-        D BLDLIST,XQORM
-        S VALMBCK="R"
-        Q
+PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;08/07/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM PATIENT LIST
+START(MODE) ;
+ N PXRMDONE,VALMBCK,VALMSG,X,XMZ,MODE1
+ S X="IORESET"
+ D ENDR^%ZISS
+ S VALMCNT=0
+ D EN^VALM("PXRM PATIENT LIST USER")
+ W IORESET
+ D KILL^%ZISS
+ Q
+ ;
+ACCESS(IEN,NODE) ;
+ ;Holders of the PXRM MANAGER key have full access to all lists.
+ ;DBIA #10076
+ I $D(^XUSEC("PXRM MANAGER",DUZ)) Q "F"
+ N ACCESS,TYPE
+ I $G(NODE)="" S NODE=$G(^PXRMXP(810.5,IEN,0))
+ S TYPE=$P(NODE,U,8)
+ I TYPE="" Q "F"
+ I TYPE="PUB" Q "F"
+ I $P(NODE,U,7)=DUZ Q "F"
+ S ACCESS="N"
+ I TYPE="PVT",$D(^PXRMXP(810.5,IEN,40,"B",DUZ)) D
+ . N USIEN,STATUS
+ . S USIEN=$O(^PXRMXP(810.5,IEN,40,"B",DUZ,""))
+ . S ACCESS=$S(USIEN="":"N",1:$P(^PXRMXP(810.5,IEN,40,USIEN,0),U,2))
+ Q ACCESS
+ ;
+BLDLIST ;
+ N IEN,PLIST
+ K ^TMP("PXRMLPU",$J)
+ K ^TMP("PXRMLPUH",$J)
+ S PLIST="PXRMLPU"
+ D LIST(MODE,PLIST,.IEN)
+ S VALMCNT=+$G(^TMP("PXRMLPU",$J,"VALMCNT"))
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMLPU",$J,"IDX",IND,IND)=IEN(IND)
+ Q
+ ;
+ENTRY ;Entry code
+ ;MODE=0 ORDER BY NAME
+ ;MODE=1 ORDER BY TYPE
+ I $G(MODE)'>0 S MODE=0
+ D BLDLIST,XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMLPU",$J)
+ K ^TMP("PXRMLPUH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="R"
+ Q
+ ;
+FORMAT(NUMBER,NAME,NODE) ;Format  entry number, name, source,
+ ;and date packed.
+ N ACCESS,DATE,COUNT,TEMP,TYPE
+ S DATE=$P(NODE,U,2),COUNT=$P(NODE,U,3)
+ S TYPE=$P(NODE,U,4),ACCESS=$P(NODE,U,5)
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S NAME=$E(NAME,1,45)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(NAME,45," ")
+ S DATE=$$FMTE^XLFDT(DATE,2)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DATE,17," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(COUNT,6," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(TYPE,4," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(ACCESS,3," ")
+ Q TEMP
+ ;
+HDR ; Header code
+ N NAME
+ S VALMHDR(1)="Available Patient Lists."
+ Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Select CO to copy patient list."
+ .S HTEXT(2)="Select COE to copy patient list to OE/RR Team."
+ .S HTEXT(3)="Select CR to delete patient list."
+ .S HTEXT(4)="Select DCD to display creation documentation."
+ .S HTEXT(5)="Select DSP to display patient list."
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMLPUH"
+ D EN^VALM("PXRM PATIENT LIST HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+LIST(MODE,PLIST,IEN) ;Build a list of patient list entries.
+ N ACCESS,COUNT,DATE,IND,FNAME,NAME,NODE,SUB,TYPE
+ ;MODE=0 build list in alphabetical order
+ ;MODE=1 build list by type of list.
+ K ^TMP($J,PLIST),^TMP(PLIST,$J)
+ S VALMCNT=0,NAME="",TYPE=""
+ F  S NAME=$O(^PXRMXP(810.5,"B",NAME)) Q:NAME=""  D
+ .S IND="" F  S IND=$O(^PXRMXP(810.5,"B",NAME,IND)) Q:'IND  D
+ ..S NODE=$G(^PXRMXP(810.5,IND,0))
+ ..S ACCESS=$$ACCESS(IND,NODE)
+ ..I ACCESS="N" Q
+ ..S FNAME=$P($G(NODE),U),DATE=$P($G(NODE),U,4)
+ ..S COUNT=+$P($G(^PXRMXP(810.5,IND,30,0)),U,4)
+ ..S TYPE=$P(NODE,U,8)
+ ..S SUB=$S(MODE=0:"NAME",1:TYPE)
+ ..S ^TMP($J,PLIST,SUB,FNAME)=IND_U_DATE_U_COUNT_U_TYPE_U_ACCESS
+ I '$D(^TMP($J,PLIST)) Q
+ ;Loop through ARRAY to populate the output list
+ ;sub is either the type of list or 'NAME'. If sort is
+ ;by TYPE show PVT lists first.
+ S SUB=""
+ F  S SUB=$O(^TMP($J,PLIST,SUB),-1) Q:SUB=""  D
+ .S FNAME=""
+ .F  S FNAME=$O(^TMP($J,PLIST,SUB,FNAME)) Q:FNAME=""  D
+ ..S NODE=^TMP($J,PLIST,SUB,FNAME),VALMCNT=VALMCNT+1
+ ..S ^TMP(PLIST,$J,VALMCNT,0)=$$FORMAT(VALMCNT,FNAME,NODE)
+ ..S IEN(VALMCNT)=$P(NODE,U,1)
+ S ^TMP(PLIST,$J,"VALMCNT")=VALMCNT
+ K ^TMP($J,PLIST)
+ Q
+ ;
+PCOPY ;Patient list copy
+ S SUB="PXRMLPU"
+ D PCOPY1(SUB)
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+PCOPY1(SUB) ;
+ ;Full Screen
+ W IORESET
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S IND="",PXRMDONE=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the patient list ien.
+ .S LISTIEN=^TMP(SUB,$J,"IDX",IND,IND)
+ .D COPY^PXRMRULE(LISTIEN)
+ Q
+ ;
+PDELETE ;Patient list delete
+ ;Full Screen
+ W IORESET
+ N DELOK,IND,LISTIEN,NODE,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S IND="",PXRMDONE=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the patient list ien.
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
+ .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
+ .S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
+ .I DELOK D DELETE^PXRMRULE(LISTIEN) Q
+ .E  D  Q
+ ..W !,"In order to delete a list you must be the creator or a Reminder Manager!"
+ ..S PXRMDONE=1 H 2
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+PEXIT ;Protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+POERR ;Patient list copy to OERR Team (#101.21)
+ ;Full Screen
+ W IORESET
+ N ACCESS,IND,LISTIEN,NODE,USIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S IND="",PXRMDONE=0
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the patient list ien.
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
+ .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
+ .S ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE)
+ .I ACCESS="F" D OERR^PXRMLPOE(LISTIEN)
+ .I ACCESS="N" D
+ ..W !,"The list cannot be copied; you must have full access to copy the list to an OE/RR team!"
+ ..S PXRMDONE=1 H 2
+ S VALMBCK="R"
+ Q
+ ;
+PLIST ;Patient list inquiry.
+ N CREAT,NAME,IND,LISTIEN,USIEN,VALMY,CREAT,NODE,TRUE
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPU
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
+ .D START^PXRMLPP(LISTIEN)
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+VIEW ;
+ D FULL^VALM1
+ N DIR,DTOUT,DUOUT,DIROUT,DIROUT,Y
+ S DIR(0)="SO^N:NAME;T:TYPE"
+ S DIR("A")="Select View Type"
+ D ^DIR
+ I $D(DTOUT),$D(DUOUT),$D(DIROUT) Q
+ I Y="N" S MODE=0 D ENTRY
+ I Y="T" S MODE=1 D ENTRY
+ Q
+ ;
+XQORM ;
+ S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST USER SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;SELECT validation
+ N EPIEN,LEVEL,LISTIEN,LRIEN,NODE,SEL
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the patient list ien
+ S LISTIEN=^TMP("PXRMLPU",$J,"IDX",SEL,SEL)
+ ;Get extract definition ien (if present)
+ S EPIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,5)
+ ;Get list rule ien
+ S LRIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,6)
+ S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
+ ;
+ ;Full screen mode
+ D FULL^VALM1
+ ;
+ ;Option to Install, Delete or Install History
+ N ACCESS,DELOK,DIR,OPTION,RIEN,X,Y
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S ACCESS=$$ACCESS(LISTIEN,NODE)
+ S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
+ S DIR(0)="SBM"_U_"CO:Copy Patient List;"
+ S DIR(0)=DIR(0)_"COE:Copy to OE/RR Team;"
+ I DELOK S DIR(0)=DIR(0)_"DE:Delete Patient List;"
+ S DIR(0)=DIR(0)_"DCD:Display Creation Documentation;"
+ S DIR(0)=DIR(0)_"DSP:Display Patient List;"
+ S DIR("A")="Select Action: "
+ S DIR("B")="DSP"
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMLPM(1)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
+ S OPTION=Y
+ ;
+ I $G(OPTION)="" G XSELE
+ ;
+ ;Copy patient list
+ I OPTION="CO" D COPY^PXRMRULE(LISTIEN)
+ Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ ;Copy to OE/RR Team
+ I OPTION="COE" D OERR^PXRMLPOE(LISTIEN)
+ Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ ;Delete patient list
+ I OPTION="DE" D PDELETE
+ ;
+ ;Display creation documentation
+ I OPTION="DCD" D EN^PXRMLCD(LISTIEN)
+ ;
+ ;Display patient list
+ I OPTION="DSP" D START^PXRMLPP(LISTIEN)
+ ;
+XSELE ;
+ D CLEAN^VALM10
+ D BLDLIST,XQORM
+ S VALMBCK="R"
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m

@@ -1 @@
-PXRMLRM ; SLC/PJH/PKR - List Rule Management ; 09/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Main entry point for PXRM LIST RULE MANAGEMENT
-START   N PXRMDONE,PXRMTYP,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
-        S X="IORESET"
-        D ENDR^%ZISS
-        S VALMCNT=0
-        ;Default view is Rule Sets
-        S PXRMTYP=3
-        D EN^VALM("PXRM LIST RULE MANAGEMENT")
-        Q
-        ;
-BLDLIST ;Build workfile
-        K ^TMP("PXRMLRM",$J)
-        N IEN,IND,PLIST
-        D LIST(.PLIST,.IEN,PXRMTYP)
-        M ^TMP("PXRMLRM",$J)=PLIST
-        S VALMCNT=PLIST("VALMCNT")
-        F IND=1:1:VALMCNT D
-        .S ^TMP("PXRMLRM",$J,"IDX",IND,IND)=IEN(IND)
-        I PXRMTYP=1 D CHGCAP^VALM("HEADER2","Finding Rule Name")
-        I PXRMTYP=2 D CHGCAP^VALM("HEADER2","Reminder Rule Name")
-        I PXRMTYP=3 D CHGCAP^VALM("HEADER2","Rule Set Name")
-        I PXRMTYP=4 D CHGCAP^VALM("HEADER2","Report Output Rule Name")
-        I PXRMTYP=5 D CHGCAP^VALM("HEADER2","Patient List Rule Name")
-        Q
-        ;
-ENTRY   ;Entry code
-        D BLDLIST,XQORM
-        Q
-        ;
-EXIT    ;Exit code
-        K ^TMP("PXRMLRM",$J)
-        K ^TMP("PXRMLRMH",$J)
-        D CLEAN^VALM10
-        D FULL^VALM1
-        S VALMBCK="Q"
-        Q
-        ;
-FRE(NUMBER,NAME,CLASS)  ;Format  entry number, name
-        ;and date packed.
-        N TCLASS,TEMP,TNAME,TSOURCE
-        S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
-        S TNAME=$E(NAME,1,60)
-        S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
-        S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
-        S TEMP=TEMP_"  "_TCLASS
-        Q TEMP
-        ;
-HDR     ; Header code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        Q
-        ;
-HELP(CALL)      ;General help text routine
-        N HTEXT
-        I CALL=1 D
-        .S HTEXT(1)="Select DE to display or edit a rule.\\"
-        .S HTEXT(2)="Select ED to edit a rule.\\"
-        ;
-        I CALL=2 D
-        .S HTEXT(1)="Select F to edit term based finding rules.\\"
-        .S HTEXT(2)="Select P to edit patient list based finding rules.\\"
-        .S HTEXT(3)="Select R to edit reminder rules.\\"
-        .S HTEXT(4)="Select S to edit rule sets. A rule set may contain"
-        .S HTEXT(5)="any of the following:\\"
-        .S HTEXT(6)=" finding list rules, patient list rules, reminder rules\\"
-        .S HTEXT(7)="These component list rules must be created before the rule set"
-        .S HTEXT(8)="can be constructed."
-        ;
-        D HELP^PXRMEUT(.HTEXT)
-        Q
-        ;
-HLP     ;Help code
-        N ORU,ORUPRMT,SUB,XQORM
-        S SUB="PXRMLRMH"
-        D EN^VALM("PXRM LIST RULE HELP")
-        Q
-        ;
-INIT    ;Init
-        S VALMCNT=0
-        Q
-        ;
-LIST(RLIST,IEN,LRTYP)   ;Build a list of list rule entries.
-        N DATA,IND,LRCLASS,LRNAME,NAME
-        ;Build the list in alphabetical order.
-        S VALMCNT=0
-        S NAME=""
-        F  S NAME=$O(^PXRM(810.4,"B",NAME)) Q:NAME=""  D
-        .S IND=$O(^PXRM(810.4,"B",NAME,"")) Q:'IND
-        .S DATA=$G(^PXRM(810.4,IND,0))
-        .I $P(DATA,U,3)'=LRTYP Q
-        .S LRNAME=$P(DATA,U)
-        .S LRCLASS=$P($G(^PXRM(810.4,IND,100)),U)
-        .S VALMCNT=VALMCNT+1
-        .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,LRNAME,LRCLASS)
-        .S IEN(VALMCNT)=IND
-        S RLIST("VALMCNT")=VALMCNT
-        Q
-        ;
-LRADD   ;Add Rule Option
-        ;
-        ;Reset Screen Mode
-        W IORESET
-        ;
-        ;Add Rule
-        D ADD^PXRMLRED
-        ;
-        ;Rebuild Workfile
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-LRINQ   ;Rule Inquiry - PXRM LIST RULE DISPLAY/EDIT entry 
-        N IND,LRIEN,VALMY
-        D EN^VALM2(XQORNOD(0))
-        ;If there is no list quit.
-        I '$D(VALMY) Q
-        S PXRMDONE=0
-        S IND=""
-        F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
-        .;Get the ien.
-        .S LRIEN=^TMP("PXRMLRM",$J,"IDX",IND,IND)
-        .D START^PXRMLRED(LRIEN,PXRMTYP)
-        D BLDLIST
-        S VALMBCK="R"
-        Q
-        ;
-PEXIT   ;Protocol exit code
-        S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
-        ;Reset after page up/down etc
-        D XQORM
-        Q
-        ;
-VIEW    ;Select view
-        W IORESET
-        S VALMBCK="R"
-        N X,Y,CODE,DIR
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="S"_U_"F:Finding Rule;"
-        S DIR(0)=DIR(0)_"P:Patient List Rule;"
-        S DIR(0)=DIR(0)_"R:Reminder Rule;"
-        S DIR(0)=DIR(0)_"S:Rule Set;"
-        S DIR("A")="TYPE OF VIEW"
-        S DIR("B")="F"
-        S DIR("?")="Select from the codes displayed. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMLRM(2)"
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        ;Change display type
-        S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,1:4)
-        S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,Y="R":2,1:4)
-        ;Rebuild Workfile
-        D BLDLIST,HDR
-        Q
-        ;
-XSEL    ;PXRM LIST RULE MANAGEMENT SELECT ENTRY validation
-        N SEL,IEN
-        S SEL=$P(XQORNOD(0),"=",2)
-        ;Remove trailing ,
-        I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
-        ;Invalid selection
-        I SEL["," D  Q
-        .W $C(7),!,"Only one item number allowed." H 2
-        .S VALMBCK="R"
-        I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
-        .W $C(7),!,SEL_" is not a valid item number." H 2
-        .S VALMBCK="R"
-        ;
-        ;Get the list ien.
-        S IEN=^TMP("PXRMLRM",$J,"IDX",SEL,SEL)
-        ;
-        ;Option to Display/Edit or Test Rule Set.
-        N DIR,OPTION,RIEN,X,Y
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="SBM"_U_"DR:Display/Edit Rule;"
-        I $G(PXRMTYP)=3 S DIR(0)=DIR(0)_"TEST:Test Rule Set"
-        S DIR("A")="Select Action: "
-        S DIR("B")="DR"
-        S DIR("?")="Select from the codes displayed."
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
-        S OPTION=Y
-        I $G(OPTION)="" G XSELE
-        ;
-        ;Display/Edit
-        I OPTION="DR"   D START^PXRMLRED(IEN,PXRMTYP)
-        Q:$D(DUOUT)!$D(DTOUT)
-        ;
-        ;Rule set test
-        I OPTION="TEST" D RSTEST^PXRMRST(IEN)
-        Q:$D(DUOUT)!$D(DTOUT)
-        ;
-XSELE   ;
-        D CLEAN^VALM10
-        D BLDLIST,XQORM
-        S VALMBCK="R"
-        Q
-        ;
-XQORM   S XQORM("#")=$O(^ORD(101,"B","PXRM LIST RULE MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT
-        S XQORM("A")="Select Item: "
-        Q
-        ;
+PXRMLRM ; SLC/PJH/PKR - List Rule Management ; 05/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM LIST RULE MANAGEMENT
+START N PXRMDONE,PXRMTYP,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
+ S X="IORESET"
+ D ENDR^%ZISS
+ S VALMCNT=0
+ ;Default view is Rule Sets
+ S PXRMTYP=3
+ D EN^VALM("PXRM LIST RULE MANAGEMENT")
+ Q
+ ;
+BLDLIST ;Build workfile
+ K ^TMP("PXRMLRM",$J)
+ N IEN,IND,PLIST
+ D LIST(.PLIST,.IEN,PXRMTYP)
+ M ^TMP("PXRMLRM",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMLRM",$J,"IDX",IND,IND)=IEN(IND)
+ I PXRMTYP=1 D CHGCAP^VALM("HEADER2","Finding Rule Name")
+ I PXRMTYP=2 D CHGCAP^VALM("HEADER2","Reminder Rule Name")
+ I PXRMTYP=3 D CHGCAP^VALM("HEADER2","Rule Set Name")
+ I PXRMTYP=4 D CHGCAP^VALM("HEADER2","Report Output Rule Name")
+ I PXRMTYP=5 D CHGCAP^VALM("HEADER2","Patient List Rule Name")
+ Q
+ ;
+ENTRY ;Entry code
+ D BLDLIST,XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMLRM",$J)
+ K ^TMP("PXRMLRMH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
+FRE(NUMBER,NAME,CLASS) ;Format  entry number, name
+ ;and date packed.
+ N TCLASS,TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,60)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
+ S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
+ S TEMP=TEMP_"  "_TCLASS
+ Q TEMP
+ ;
+HDR ; Header code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Select DE to display or edit a rule."
+ .S HTEXT(2)="Select ED to edit a rule"
+ ;
+ I CALL=2 D
+ .S HTEXT(1)=" Select F to edit term based finding rules."
+ .S HTEXT(2)=" Select P to edit patient list based finding rules."
+ .S HTEXT(3)=" Select R to edit reminder rules."
+ .S HTEXT(4)=" Select S to edit rule sets. A rule set may contain either "
+ .S HTEXT(5)="finding list rules or patient list rules or both. These "
+ .S HTEXT(6)="component list rules must be created before the rule set "
+ .S HTEXT(7)="can be constructed."
+ ;
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+HLP ;Help code
+ N ORU,ORUPRMT,SUB,XQORM
+ S SUB="PXRMLRMH"
+ D EN^VALM("PXRM LIST RULE HELP")
+ Q
+ ;
+INIT ;Init
+ S VALMCNT=0
+ Q
+ ;
+LIST(RLIST,IEN,LRTYP) ;Build a list of list rule entries.
+ N DATA,IND,LRCLASS,LRNAME,NAME
+ ;Build the list in alphabetical order.
+ S VALMCNT=0
+ S NAME=""
+ F  S NAME=$O(^PXRM(810.4,"B",NAME)) Q:NAME=""  D
+ .S IND=$O(^PXRM(810.4,"B",NAME,"")) Q:'IND
+ .S DATA=$G(^PXRM(810.4,IND,0))
+ .I $P(DATA,U,3)'=LRTYP Q
+ .S LRNAME=$P(DATA,U)
+ .S LRCLASS=$P($G(^PXRM(810.4,IND,100)),U)
+ .S VALMCNT=VALMCNT+1
+ .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,LRNAME,LRCLASS)
+ .S IEN(VALMCNT)=IND
+ S RLIST("VALMCNT")=VALMCNT
+ Q
+ ;
+LRADD ;Add Rule Option
+ ;
+ ;Reset Screen Mode
+ W IORESET
+ ;
+ ;Add Rule
+ D ADD^PXRMLRED
+ ;
+ ;Rebuild Workfile
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+LRINQ ;Rule Inquiry - PXRM LIST RULE DISPLAY/EDIT entry 
+ N IND,LRIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LRIEN=^TMP("PXRMLRM",$J,"IDX",IND,IND)
+ .D START^PXRMLRED(LRIEN,PXRMTYP)
+ D BLDLIST
+ S VALMBCK="R"
+ Q
+ ;
+PEXIT ;Protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+VIEW ;Select view
+ W IORESET
+ S VALMBCK="R"
+ N X,Y,CODE,DIR
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="S"_U_"F:Finding Rule;"
+ S DIR(0)=DIR(0)_"P:Patient List Rule;"
+ S DIR(0)=DIR(0)_"R:Reminder Rule;"
+ S DIR(0)=DIR(0)_"S:Rule Set;"
+ S DIR("A")="TYPE OF VIEW"
+ S DIR("B")="F"
+ S DIR("?")="Select from the codes displayed. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMLRM(2)"
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ ;Change display type
+ S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,1:4)
+ S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,Y="R":2,1:4)
+ ;Rebuild Workfile
+ D BLDLIST,HDR
+ Q
+ ;
+XSEL ;PXRM LIST RULE MANAGEMENT SELECT ENTRY validation
+ N SEL,IEN
+ S SEL=$P(XQORNOD(0),"=",2)
+ ;Remove trailing ,
+ I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
+ ;Invalid selection
+ I SEL["," D  Q
+ .W $C(7),!,"Only one item number allowed." H 2
+ .S VALMBCK="R"
+ I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
+ .W $C(7),!,SEL_" is not a valid item number." H 2
+ .S VALMBCK="R"
+ ;
+ ;Get the list ien.
+ S IEN=^TMP("PXRMLRM",$J,"IDX",SEL,SEL)
+ ;
+ ;Option to Display/Edit or Test Rule Set.
+ N DIR,OPTION,RIEN,X,Y
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="SBM"_U_"DR:Display/Edit Rule;"
+ I $G(PXRMTYP)=3 S DIR(0)=DIR(0)_"TEST:Test Rule Set"
+ S DIR("A")="Select Action: "
+ S DIR("B")="DR"
+ S DIR("?")="Select from the codes displayed."
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
+ S OPTION=Y
+ I $G(OPTION)="" G XSELE
+ ;
+ ;Display/Edit
+ I OPTION="DR"   D START^PXRMLRED(IEN,PXRMTYP)
+ Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ ;Rule set test
+ I OPTION="TEST" D RSTEST^PXRMRST(IEN)
+ Q:$D(DUOUT)!$D(DTOUT)
+ ;
+XSELE ;
+ D CLEAN^VALM10
+ D BLDLIST,XQORM
+ S VALMBCK="R"
+ Q
+ ;
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM LIST RULE MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m

@@ -1 @@
-PXRMMH  ; SLC/PKR - Handle mental health findings. ;11/23/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=======================================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate mental health findings.
-        D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL)
-        Q
-        ;
-        ;=======================================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;Evaluate mental health term findings
-        ;for patient lists.
-        D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
-        Q
-        ;
-        ;=======================================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;Evaluate mental
-        ;health instrument terms.
-        D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
-        Q
-        ;
-        ;=======================================================
-GETDATA(DASP,FIEVT)     ;Return the data for a MH Administrations entry.
-        ;Some tests require the YSP key in order to get a score.
-        N DAS,DATA,IND,SCALE
-        S DAS=$P(DASP,"S",1)
-        S SCALE=+$P(DASP,"S",2)
-        ;DBIA #5043
-        D ENDAS71^YTQPXRM6(.DATA,DAS)
-        I $G(DATA(1))="[ERROR]" Q
-        I SCALE=0 S SCALE=+$O(DATA("SI",""))
-        S FIEVT("MH TEST")=$P(DATA(2),U,3)
-        S IND=0
-        F  S IND=$O(DATA("SI",IND)) Q:IND=""  S FIEVT("S",IND)=$P(DATA("SI",IND),U,3,4)
-        S IND=0
-        F  S IND=$O(DATA("R",IND)) Q:IND=""  S FIEVT("R",IND)=$P(DATA("R",IND),U,6)
-        I $D(DATA("SI",SCALE)) S FIEVT("VALUE")=FIEVT("S",SCALE),FIEVT("SCALE NAME")=$P(DATA("SI",SCALE),U,2)
-        Q
-        ;
-        ;=======================================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        N DATE,IND,JND,MHTEST,NOUT,SCALE,SNAME,SCORE,TEXTOUT
-        S MHTEST="Mental Health Test: "_IFIEVAL("MH TEST")_" = "
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S DATE="("_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))_")"
-        . S TEMP=MHTEST_DATE
-        . S SNAME=$G(IFIEVAL(IND,"SCALE NAME"))
-        . I SNAME'="" S TEMP=TEMP_" scale: "_SNAME_" -"
-        . S SCORE=$G(IFIEVAL(IND,"VALUE"))
-        . I SCORE'="" S TEMP=TEMP_"  raw score: "_$P(SCORE,U,1)_", transformed score: "_$P(SCORE,U,2)
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;=======================================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        N IND,JND,MHTEST,NOUT,SCALE,SNAME,SCORE,TEXTOUT
-        S MHTEST=IFIEVAL("MH TEST")
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Mental Health Test: "_MHTEST
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S TEMP=$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))
-        . S SNAME=$G(IFIEVAL(IND,"SCALE NAME"))
-        . I SNAME'="" S TEMP=TEMP_" scale: "_SNAME_" -"
-        . S SCORE=$G(IFIEVAL(IND,"VALUE"))
-        . I SCORE'="" S TEMP=TEMP_"  raw score: "_$P(SCORE,U,1)_", transformed score: "_$P(SCORE,U,2)
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;=======================================================
-SCHELP(MHIEN)   ;Xecutable help for MH SCALE
-        N DATA,IND,JND,NUM,SCALE,SNUM
-        I MHIEN=0 D  Q
-        . S SCALE(1)="This is not a valid Mental Health finding, selecting an MH scale does"
-        . S SCALE(2)="not make sense"
-        . D EN^DDIOL(.SCALE)
-        ;DBIA #5053
-        D SCALES^YTQPXRM5(.DATA,MHIEN)
-        I DATA(1)="ERROR" D  Q
-        . S SCALE(1)="There are no scales for this test."
-        . D EN^DDIOL(.SCALE)
-        S SCALE(1)="Valid scales are:"
-        S SCALE(2)="SCALE NUMBER  SCALE NAME"
-        S SCALE(3)="------------------------"
-        S IND=0,JND=3
-        F  S IND=$O(DATA("S",IND)) Q:IND=""  D
-        . S JND=JND+1
-        . S NUM=6-$L(IND)
-        . S SCALE(JND)=$$INSCHR^PXRMEXLC(NUM," ")_(IND)_"        "_$P(DATA("S",IND),U,1)
-        D EN^DDIOL(.SCALE)
-        Q
-        ;
-        ;=======================================================
-SCHELPD(DA)     ;Xecutable help for MH SCALE in Result Group file 801.41
-        N MHIEN
-        S MHIEN=+$P($G(^PXRMD(801.41,DA,50)),U)
-        D SCHELP^PXRMMH(MHIEN)
-        Q
-        ;=======================================================
-SCHELPF ;Xecutable help for MH SCALE in 811.9 findings.
-        N FIND0,MHIEN
-        S FIND0=^PXD(811.9,DA(1),20,DA,0)
-        I FIND0["YTT(601.71" S MHIEN=$P(FIND0,";",1)
-        E  S MHIEN=0
-        D SCHELP(MHIEN)
-        Q
-        ;
-        ;=======================================================
-SCHELPT ;Xecutable help for MH SCALE in 811.5 findings.
-        N MHIEN,TFIND0
-        S TFIND0=^PXRMD(811.5,DA(1),20,DA,0)
-        I TFIND0["YTT(601.71" S MHIEN=$P(TFIND0,";",1)
-        E  S MHIEN=0
-        D SCHELP(MHIEN)
-        Q
-        ;
-        ;=======================================================
-SCNAME(TEST,SCNUM)      ;Given the test ien and scale number return the
-        ;scale name.
-        N DATA,SCNAME
-        D SCALES^YTQPXRM5(.DATA,TEST)
-        Q $G(DATA("S",SCNUM))
-        ;
-        ;=======================================================
-SEVALFI(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST)        ;
-        N FIEV,FINDING,IND,YS,DATA
-        S YS("CODE")=ITEM,YS("DFN")=DFN
-        S YS("BEGIN")=BDT,YS("END")=EDT
-        ;PTTEST^YTQPXRM2 does not understand "*" for a limit so use 99.
-        I NGET="*" S NGET=99
-        S YS("LIMIT")=$S(SDIR=-1:NGET,1:-NGET)
-        ;DBIA #5035
-        D PTTEST^YTQPXRM2(.DATA,.YS)
-        S NFOUND=$P(DATA(1),U,2)
-        I NFOUND=0 Q
-        F IND=1:1:NFOUND S FLIST(IND)=DATA(IND+1)
-        Q
-        ;
-        ;=======================================================
-SEVALPL(ITEM,NOCC,BDT,EDT,PLIST)        ;Use MH API to get patient list. Called
-        ;from PXRMINDL.
-        N YS
-        ;YTAPI10A does not understand "*" for a limit so use 99.
-        ;OCCUR^YTQPXRM1 does not understand "*" for a limit so use 99.
-        I NOCC="*" S NOCC=99
-        S YS("CODE")=ITEM,YS("BEGIN")=BDT,YS("END")=EDT,YS("LIMIT")=NOCC
-        ;DBIA #5034
-        D OCCUR^YTQPXRM1(PLIST,.YS)
-        Q
-        ;
-        ;=======================================================
-VSCALE(X,FIND0) ;Make sure that the mental health scale is valid.
-        ;Either the scale number or the scale name can be used.
-        N DATA,IND,MHIEN,MHTEST,SCALE,VALID
-        S MHTEST=$P(FIND0,U,1)
-        S MHIEN=$P(MHTEST,";",1)
-        D SCALES^YTQPXRM5(.DATA,MHIEN)
-        I +X>0 S VALID=$S($D(DATA("S",X)):1,1:0)
-        E  D
-        . S IND=1,VALID=0
-        . F  S IND=$O(DATA("S",IND)) Q:(VALID)!(IND="")  D
-        .. I X=$P(DATA("S",IND),U,1) S VALID=1 Q
-        I 'VALID D EN^DDIOL(X_" is not a valid scale for this test!")
-        I $O(DATA(""),-1)>20 H 1
-        Q VALID
-        ;
-        ;=======================================================
-VSCALED(X,DA)   ;Make sure that the mental health scale is valid for a result
-        ;group.
-        I X="" Q 1
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q 1
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q 1
-        N MHTEST
-        S MHTEST=$P($G(^PXRMD(801.41,DA,50)),U)
-        Q $$VSCALE(X,MHTEST)
-        ;
-        ;=======================================================
-VSCALEF(X)      ;Make sure that the mental health scale is valid for a finding.
-        I X="" Q 1
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q 1
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q 1
-        N FIND0
-        S FIND0=^PXD(811.9,DA(1),20,DA,0)
-        Q $$VSCALE(X,FIND0)
-        ;
-        ;=======================================================
-VSCALET(X)      ;Make sure that the mental health scale is valid for a 
-        ;term finding.
-        I X="" Q 1
-        ;Do not execute as part of a verify fields.
-        I $G(DIUTIL)="VERIFY FIELDS" Q 1
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q 1
-        N TFIND0
-        S TFIND0=^PXRMD(811.5,DA(1),20,DA,0)
-        Q $$VSCALE(X,TFIND0)
-        ;
-        ;=======================================================
-WARN    ;Warn the user that they must select a scale if they intend to use
-        ;a condition.
-        W !,"Remember that the score is returned as raw score^transformed score,"
-        W !,"so if your Condition uses the raw score use +V or $P(V,U,1) and if"
-        W !,"it uses the transformed score use $P(V,U,2)."
-        Q
-        ;
+PXRMMH ; SLC/PKR - Handle mental health findings. ;04/05/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=======================================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate mental health findings.
+ D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL)
+ Q
+ ;
+ ;=======================================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate mental health term findings
+ ;for patient lists.
+ D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
+ Q
+ ;=======================================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate mental
+ ;health instrument terms.
+ D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
+ Q
+ ;
+ ;=======================================================
+GETDATA(DAS,FIEVT) ;Return the data for a Psych Instrument Patient entry.
+ ;Some tests require the YSP key in order to get a score.
+ N DASP,IND,SCALE,YSDATA
+ ;DBIA #4442
+ S DASP=$P(DAS,"S",1)
+ S SCALE=$P(DAS,"S",2)
+ D ENDAS^YTAPI10(.YSDATA,DASP)
+ I $G(YSDATA(0))="[ERROR]" Q
+ S FIEVT("MH TEST")=$P(YSDATA(2),U,3)
+ I FIEVT("MH TEST")["GAF" S FIEVT("RATING")=$P(YSDATA(3),U,2) Q
+ ;If no scale is specified use the first set of results.
+ S IND=$S(SCALE="":6,1:SCALE+5)
+ S FIEVT("YSDATA")=$G(YSDATA(IND))
+ S FIEVT("SCALE NAME")=$P(FIEVT("YSDATA"),U,2)
+ S (FIEVT("RAW SCORE"),FIEVT("VALUE"))=$P(FIEVT("YSDATA"),U,3)
+ S FIEVT("TRANSFORMED SCORE")=$P(FIEVT("YSDATA"),U,4)
+ Q
+ ;
+ ;=======================================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N DATE,IND,JND,MHTEST,NAME,NOUT,RATING,RSCORE,SCORE,TEXTOUT,TSCORE
+ S MHTEST=IFIEVAL("MH TEST")
+ ;Remove the dashes surrounding the name.
+ S MHTEST=$TR(MHTEST,"-","")
+ S NAME="Mental Health Test: "_MHTEST_" = "
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S RSCORE=$G(IFIEVAL(IND,"RAW SCORE"))
+ . S TSCORE=$G(IFIEVAL(IND,"TRANSFORMED SCORE"))
+ . S RATING=$G(IFIEVAL(IND,"RATING"))
+ . S SCORE=$S(RATING'="":RATING,TSCORE'="":TSCORE,RSCORE'="":RSCORE,1:"")
+ . S TEMP=NAME_SCORE_" ("_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))_")"
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;=======================================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ N DATE,IND,JND,MHTEST,NOUT,RATING,RSCORE,TEXTOUT,TSCORE
+ S MHTEST=IFIEVAL("MH TEST")
+ ;Remove the dashes surrounding the name.
+ S MHTEST=$TR(MHTEST,"-","")
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Mental Health Test: "_MHTEST
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S TEMP=$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))
+ . S RSCORE=$G(IFIEVAL(IND,"RAW SCORE"))
+ . I RSCORE'="" S TEMP=TEMP_" raw score - "_RSCORE
+ . S TSCORE=$G(IFIEVAL(IND,"TRANSFORMED SCORE"))
+ . I TSCORE'="" S TEMP=TEMP_"; transformed score - "_TSCORE
+ . S RATING=$G(IFIEVAL(IND,"RATING"))
+ . I RATING'="" S TEMP=TEMP_" Rating: "_RATING
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;=======================================================
+SCHELP(MHIEN) ;Xecutable help for MH SCALE
+ N IND,JND,NUM,SCALE,TEMP,TEMP1
+ I MHIEN=0 D  Q
+ . S SCALE(1)="This is not a valid Mental Health finding, selecting an MH scale does"
+ . S SCALE(2)="not make sense"
+ . D EN^DDIOL(.SCALE)
+ S SCALE(1)="SCALE NUMBER  SCALE NAME"
+ S SCALE(2)="------------------------"
+ S IND=0
+ S JND=2
+ F  S IND=$O(^YTT(601,MHIEN,"S",IND)) Q:+IND=0  D
+ . S TEMP=^YTT(601,MHIEN,"S",IND,0)
+ . S JND=JND+1
+ . S TEMP1=$P(TEMP,U,1)
+ . S NUM=6-$L(TEMP1)
+ . S SCALE(JND)=$$INSCHR^PXRMEXLC(NUM," ")_TEMP1_"        "_$P(TEMP,U,2)
+ D EN^DDIOL(.SCALE)
+ Q
+ ;
+ ;=======================================================
+SCHELPF ;Xecutable help for MH SCALE in 811.9 findings.
+ N FIND0,MHIEN
+ S FIND0=^PXD(811.9,DA(1),20,DA,0)
+ I FIND0["YTT(601" S MHIEN=$P(FIND0,";",1)
+ E  S MHIEN=0
+ D SCHELP(MHIEN)
+ Q
+ ;
+ ;=======================================================
+SCHELPT ;Xecutable help for MH SCALE in 811.5 findings.
+ N MHIEN,TFIND0
+ S TFIND0=^PXRMD(811.5,DA(1),20,DA,0)
+ I TFIND0["YTT(601" S MHIEN=$P(TFIND0,";",1)
+ E  S MHIEN=0
+ D SCHELP(MHIEN)
+ Q
+ ;
+ ;=======================================================
+SEVALFI(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;
+ N FIEV,FINDING,IND,YS,YSDATA
+ S YS("CODE")=ITEM,YS("DFN")=DFN
+ S YS("BEGIN")=BDT,YS("END")=EDT
+ ;YTAPI10A does not understand "*" for a limit so use 99.
+ I NGET="*" S NGET=99
+ S YS("LIMIT")=$S(SDIR=-1:NGET,1:-NGET)
+ ;DBIA #4458
+ D PTTEST^YTAPI10A(.YSDATA,.YS)
+ S NFOUND=$P(YSDATA(1),U,2)
+ I NFOUND=0 Q
+ F IND=1:1:NFOUND S FLIST(IND)=YSDATA(IND+1)
+ Q
+ ;
+ ;=======================================================
+SEVALPL(ITEM,NOCC,BDT,EDT,PLIST) ;Use MH API to get patient list. Called
+ ;from PXRMINDL.
+ N YS
+ ;YTAPI10A does not understand "*" for a limit so use 99.
+ I NOCC="*" S NOCC=99
+ S YS("CODE")=ITEM,YS("BEGIN")=BDT,YS("END")=EDT,YS("LIMIT")=NOCC
+ ;DBIA #4458
+ D OCCUR^YTAPI10A(PLIST,.YS)
+ Q
+ ;
+ ;=======================================================
+VSCALE(X,FIND0) ;Make sure that the mental health scale is valid.
+ ;Either the scale number or the scale name can be used.
+ N MHIEN,MHTEST,SCALE,VALID
+ S MHTEST=$P(FIND0,U,1)
+ S MHIEN=$P(MHTEST,";",1)
+ I +X>0 D  Q VALID
+ . S VALID=$S($D(^YTT(601,MHIEN,"S",X)):1,1:0)
+ E  D
+ . S SCALE=$O(^YTT(601,MHIEN,"S","C",X,""))
+ . S VALID=$S(SCALE="":0,1:1)
+ Q VALID
+ ;
+ ;=======================================================
+VSCALEF(X) ;Make sure that the mental health scale is valid for a finding.
+ I X="" Q 1
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q 1
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q 1
+ N FIND0
+ S FIND0=^PXD(811.9,DA(1),20,DA,0)
+ Q $$VSCALE(X,FIND0)
+ ;
+ ;=======================================================
+VSCALET(X) ;Make sure that the mental health scale is valid for a 
+ ;term finding.
+ I X="" Q 1
+ ;Do not execute as part of a verify fields.
+ I $G(DIUTIL)="VERIFY FIELDS" Q 1
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q 1
+ N TFIND0
+ S TFIND0=^PXRMD(811.5,DA(1),20,DA,0)
+ Q $$VSCALE(X,TFIND0)
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m

@@ -1 @@
-PXRMMST ; SLC/PKR - Routines for dealing with MST. ;03/29/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;Use of DGMSTAPI supported by DBIA #2716.
-        ;====================================================
-GSYINFO(TYPE)   ;Return the Clinical Reminders MST synchronization date
-        ;and the number of updates made. The format is an up-arrow delimited
-        ;string. The first piece is the date and the second is the number
-        ;of updates. If TYPE is "I" then the data for the initial
-        ;synchronization is returned. For any other value the data for the
-        ;last daily synchronization is returned.
-        I $G(TYPE)="I" Q $P($G(^PXRM(800,1,"MST")),U,1,2) Q
-        Q $P($G(^PXRM(800,1,"MST")),U,3,4)
-        ;
-        ;====================================================
-QUE     ;Queue the MST synchronization job.
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        W !,"Queue the Clinical Reminders MST synchronization."
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S SDTIME=Y
-        K DIR
-        S DIR(0)="YA"
-        S DIR("A")="Do you want to run the MST synchronization at the same time every day? "
-        S DIR("B")="Y"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S STIME=$S(Y:"1."_$P(SDTIME,".",2),1:-1)
-        ;
-        ;Put the task into the queue.
-        K ZTSAVE
-        S ZTSAVE("STIME")=STIME
-        S ZTRTN="SYNCH^PXRMMST"
-        S ZTDESC="Clinical Reminders MST synchronization job"
-        S ZTDTH=SDTIME
-        S ZTIO=""
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued."
-        Q
-        ;
-        ;====================================================
-STATUS(DFN,TEST,DATE,VALUE,TEXT)        ;Computed finding for checking a
-        ;patient's MST status.
-        N IEN,TEMP
-        S TEMP=$$GETSTAT^DGMSTAPI(DFN)
-        S IEN=$P(TEMP,U,1)
-        I IEN=-1 D  Q
-        . S TEST=0,VALUE="",DATE=$$NOW^PXRMDATE
-        I IEN=0 D  Q
-        . S TEST=0
-        . S VALUE=$P(TEMP,U,2)
-        . S DATE=$P(TEMP,U,3)
-        . S TEXT="No MST status found"
-        ;If we get to here then a valid entry was found.
-        S TEST=1
-        S VALUE=$P(TEMP,U,2)
-        S DATE=$P(TEMP,U,3)
-        Q
-        ;
-        ;====================================================
-STCODE(TERM)    ;Return the MST status code based on the term name.
-        N STCODE
-        S STCODE=$S(TERM="VA-MST DECLINES REPORT":"D",TERM="VA-MST NEGATIVE REPORT":"N",TERM="VA-MST POSITIVE REPORT":"Y",1:"U")
-        Q STCODE
-        ;
-        ;====================================================
-SYNCH   ;Synchronize the MST history file.
-        N INID,LTIME,NUMUPD,START,TEMP
-        ;STIME is passed from QUE via ZTSAVE.
-        D UPDSTAT(.NUMUPD,.START)
-        ;If the initial sync data has been stored then update the daily
-        ;data.
-        S INID=+$P($G(^PXRM(800,1,"MST")),U,1)
-        I INID>0 D
-        . S $P(^PXRM(800,1,"MST"),U,3)=$$NOW^XLFDT
-        . S $P(^PXRM(800,1,"MST"),U,4)=NUMUPD
-        . S $P(^PXRM(800,1,"MST"),U,6)=START
-        E  D
-        . S $P(^PXRM(800,1,"MST"),U,1)=$$NOW^XLFDT
-        . S $P(^PXRM(800,1,"MST"),U,2)=NUMUPD
-        . S $P(^PXRM(800,1,"MST"),U,5)=START
-        ;
-        ;Cleanup the task stuff.
-        I STIME=-1 S ZTREQ="@" Q
-        E  D
-        . S TEMP=$G(^PXRM(800,1,"MST"))
-        . S LTIME=+$P(TEMP,U,3)
-        . I LTIME=0 S LTIME=+$P(TEMP,U,1)
-        .;Adding STIME sets the new starting time at exactly one day following
-        .;the previous starting time.
-        . S $P(ZTREQ,U,1)=$P(LTIME,".",1)+STIME
-        Q
-        ;
-        ;====================================================
-SYNREP  ;Provide a report of the synchronization data.
-        N EDTIME,EITIME,IDATE,LDATE,NIUPD,NLUPD,TEMP
-        S TEMP=$G(^PXRM(800,1,"MST"))
-        S IDATE=$$FMTE^XLFDT($P(TEMP,U,1))
-        I IDATE=0 S IDATE="none"
-        S NIUPD=$P(TEMP,U,2)
-        S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),2)
-        S LDATE=$$FMTE^XLFDT($P(TEMP,U,3))
-        I LDATE=0 S LDATE="none"
-        S NLUPD=$P(TEMP,U,4)
-        S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),2)
-        W !!,"Clinical Reminders MST Synchronization Report"
-        W !,"---------------------------------------------"
-        W !,"Initial synchronization date: ",IDATE
-        W !,"Number of updates made: ",NIUPD
-        I EITIME>60 D
-        . S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),3)
-        . W !,"Elapsed time: ",EITIME
-        E  W !,"Elapsed time: ",EITIME," secs"
-        W !!,"Last daily synchronization date: ",LDATE
-        W !,"Number of updates made: ",NLUPD
-        I EDTIME>60 D
-        . S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),3)
-        . W !,"Elapsed time: ",EDTIME
-        E  W !,"Elapsed time: ",EDTIME," secs"
-        Q
-        ;
-        ;====================================================
-UPDATE(DFN,VISIT,SOURCE,STCODE,TYPE)    ;Make an update to the MST History file.
-        N DATE,MSTDATE,PROV,STAT,TEMP,UPDSTAT,VPRVIEN
-        S UPDSTAT=-1
-        ;If the update is because of a protocol event use NOW for the
-        ;date/time. If it is being done as part of a synchronization use
-        ;the date the visit was created.
-        S DATE=$S(TYPE="PROTOCOL":$$NOW^XLFDT,1:$P($G(^AUPNVSIT(VISIT,0)),U,2))
-        ;If the date does not contain the time use noon.
-        I DATE'["." S DATE=DATE_".12"
-        S STAT=$$GETSTAT^DGMSTAPI(DFN)
-        S MSTDATE=$S($P(STAT,U,1)>0:$P(STAT,U,3),1:0)
-        I DATE>MSTDATE D
-        .;Determine the provider.
-        . S TEMP=$P(SOURCE,";",2)_$P(SOURCE,";",1)_",12)"
-        . S PROV=$P($G(@TEMP),U,4)
-        . I PROV="" D
-        ..;DBIA #2316
-        .. S VPRVIEN=+$O(^AUPNVPRV("AD",VISIT,""))
-        .. I VPRVIEN>0 S PROV=$P(^AUPNVPRV(VPRVIEN,0),U,1)
-        . S UPDSTAT=$$NEWSTAT^DGMSTAPI(DFN,STCODE,DATE,PROV)
-        . I +UPDSTAT=-1 D
-        .. N FN,GBL,IEN,NAME,TARGET,XMSUB,VADM
-        .. K ^TMP("PXRMXMZ",$J)
-        .. S XMSUB="CLINICAL REMINDER MST UPDATE PROBLEM"
-        .. S ^TMP("PXRMXMZ",$J,1,0)="NEWSTAT^DGMSTAPI returned the following error:"
-        .. S ^TMP("PXRMXMZ",$J,2,0)=$P(UPDSTAT,U,2)
-        .. S ^TMP("PXRMXMZ",$J,3,0)="The following data was passed to NEWSTAT^DGMSTAPI"
-        .. S ^TMP("PXRMXMZ",$J,4,0)="DFN = "_DFN
-        .. S ^TMP("PXRMXMZ",$J,5,0)="Status code = "_STCODE
-        .. S ^TMP("PXRMXMZ",$J,6,0)="Date = "_DATE
-        .. S ^TMP("PXRMXMZ",$J,7,0)="Provider = "_PROV
-        .. S ^TMP("PXRMXMZ",$J,8,0)="Data source = "_SOURCE
-        .. S ^TMP("PXRMXMZ",$J,9,0)="This corresponds to the following:"
-        .. D DEM^VADPT
-        .. S ^TMP("PXRMXMZ",$J,10,0)="Patient = "_VADM(1)
-        .. S ^TMP("PXRMXMZ",$J,11,0)="SSN = "_$P(VADM(2),U,2)
-        .. S ^TMP("PXRMXMZ",$J,12,0)="MST Status = "_$$EXTERNAL^DILFD(29.11,3,"",STCODE)
-        .. S ^TMP("PXRMXMZ",$J,13,0)="Date = "_$$FMTE^XLFDT(DATE,"5Z")
-        .. S TEMP=$S(PROV="":"Unknown",1:TEMP=$$GET1^DIQ(200,PROV,.01,"","",""))
-        .. I TEMP="" S TEMP="Unknown"
-        .. S ^TMP("PXRMXMZ",$J,14,0)="Provider = "_TEMP
-        .. S GBL=$P($P(SOURCE,";",2),"(",1)
-        .. S TEMP=GBL_"(0)"
-        .. S FN=+$P(@TEMP,U,2)
-        .. S TEMP=GBL_"("_$P(SOURCE,";",1)_",0)"
-        .. S TEMP=$G(@TEMP)
-        .. S IEN=$P(TEMP,U,1)
-        .. D FIELD^DID(FN,.01,"N","POINTER","TARGET")
-        .. S GBL="^"_$P(TARGET("POINTER"),"(",1)
-        .. S TEMP=GBL_"(0)"
-        .. S FN=$P(@TEMP,U,1)
-        .. S TEMP=GBL_"("_IEN_",0)"
-        .. S NAME=$P(@TEMP,U,1)
-        .. S ^TMP("PXRMXMZ",$J,14,0)="Data type = "_FN
-        .. S ^TMP("PXRMXMZ",$J,15,0)="Name = "_NAME
-        .. D SEND^PXRMMSG(XMSUB)
-        Q UPDSTAT
-        ;
-        ;====================================================
-UPDPAT(DFN,VISIT,VFL)   ;Update the MST history file for a single patient
-        ;using term mappings. Called from DATACHG^PXRMPINF which is invoked
-        ;by the protocol PXK VISIT DATA EVENT.
-        N AFTER,BEFORE,DGBL,SP,STCODE,SIEN,SOURCE
-        N TEMP,TERM,TERMIEN,VF
-        ;Search all the MST terms to build patient lists.
-        F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D
-        . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,""))
-        . S VF=""
-        . F  S VF=$O(VFL(VF)) Q:VF=""  D
-        .. I VFL(VF)=U Q
-        .. S DGBL=$P(VFL(VF),U,1)
-        .. I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL)) Q
-        .. S SIEN=""
-        .. F  S SIEN=$O(^TMP("PXKCO",$J,VISIT,VF,SIEN)) Q:SIEN=""  D
-        ... S AFTER=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"AFTER"))
-        ... S BEFORE=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"BEFORE"))
-        ... I AFTER=BEFORE Q
-        ... S SP=$P(AFTER,U,1)
-        ... I SP="" Q
-        ... I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL,SP)) Q
-        ... S SOURCE=SIEN_";^"_$P(VFL(VF),U,2)
-        ...;The status code depends on the term name.
-        ... S STCODE=$$STCODE(TERM)
-        ... S TEMP=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"PROTOCOL")
-        Q
-        ;
-        ;====================================================
-UPDSTAT(NUMUPD,START)   ;Update the MST history file using term mappings.
-        N DAS,DATA,DFN,FILENUM,FINDPA,INDEX,ITEM,NOCC,STCODE,SOURCE
-        N TEMP,TERM,TERMARR,TERMIEN,UPDSTAT,VDATE,VISIT
-        S FINDPA=""
-        ;Set the start time for the synchronization.
-        S START=$$NOW^XLFDT
-        S INDEX="PXRM_MST_LIST"
-        S NUMUPD=0
-        ;Search all the MST terms to build patient lists. Only V file data
-        ;is used for the update.
-        F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D
-        . K TERMARR,^TMP($J,INDEX)
-        .;The status code depends on the term name.
-        . S STCODE=$$STCODE(TERM)
-        . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,""))
-        . I TERMIEN="" Q
-        . D TERM^PXRMLDR(TERMIEN,.TERMARR)
-        . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,INDEX)
-        . S DFN=0
-        . F  S DFN=+$O(^TMP($J,INDEX,1,DFN)) Q:DFN=0  D
-        .. S ITEM=""
-        .. F  S ITEM=$O(^TMP($J,INDEX,1,DFN,ITEM)) Q:ITEM=""  D
-        ... S NOCC=0
-        ... F  S NOCC=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC)) Q:NOCC=""  D
-        .... S FILENUM=""
-        .... F  S FILENUM=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM)) Q:FILENUM=""  D
-        ..... S TEMP=^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM)
-        ..... S DAS=$P(TEMP,U,1)
-        ..... K DATA
-        ..... D GETDATA^PXRMDATA(FILENUM,DAS,.DATA)
-        ..... S VISIT=$G(DATA("VISIT"))
-        ..... I VISIT="" Q
-        ..... S SOURCE=DAS_";"_^PXRMINDX(FILENUM,"GLOBAL NAME")
-        ..... S UPDSTAT=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"SYNCH")
-        ..... I UPDSTAT'=-1 S NUMUPD=NUMUPD+1
-        K ^TMP($J,INDEX)
-        Q
-        ;
+PXRMMST ; SLC/PKR - Routines for dealing with MST. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;Use of DGMSTAPI supported by DBIA #2716.
+ ;====================================================
+GSYINFO(TYPE) ;Return the Clinical Reminders MST synchronization date
+ ;and the number of updates made. The format is an up-arrow delimited
+ ;string. The first piece is the date and the second is the number
+ ;of updates. If TYPE is "I" then the data for the initial
+ ;synchronization is returned. For any other value the data for the
+ ;last daily synchronization is returned.
+ I $G(TYPE)="I" Q $P($G(^PXRM(800,1,"MST")),U,1,2) Q
+ Q $P($G(^PXRM(800,1,"MST")),U,3,4)
+ ;
+ ;====================================================
+QUE ;Queue the MST synchronization job.
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ W !,"Queue the Clinical Reminders MST synchronization."
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S SDTIME=Y
+ K DIR
+ S DIR(0)="YA"
+ S DIR("A")="Do you want to run the MST synchronization at the same time every day? "
+ S DIR("B")="Y"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S STIME=$S(Y:"1."_$P(SDTIME,".",2),1:-1)
+ ;
+ ;Put the task into the queue.
+ K ZTSAVE
+ S ZTSAVE("STIME")=STIME
+ S ZTRTN="SYNCH^PXRMMST"
+ S ZTDESC="Clinical Reminders MST synchronization job"
+ S ZTDTH=SDTIME
+ S ZTIO=""
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued."
+ Q
+ ;
+ ;====================================================
+STATUS(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking a
+ ;patient's MST status.
+ N IEN,TEMP
+ S TEMP=$$GETSTAT^DGMSTAPI(DFN)
+ S IEN=$P(TEMP,U,1)
+ I IEN=-1 D  Q
+ . S TEST=0,VALUE="",DATE=$$NOW^PXRMDATE
+ I IEN=0 D  Q
+ . S TEST=0
+ . S VALUE=$P(TEMP,U,2)
+ . S DATE=$P(TEMP,U,3)
+ . S TEXT="No MST status found"
+ ;If we get to here then a valid entry was found.
+ S TEST=1
+ S VALUE=$P(TEMP,U,2)
+ S DATE=$P(TEMP,U,3)
+ Q
+ ;
+ ;====================================================
+STCODE(TERM) ;Return the MST status code based on the term name.
+ N STCODE
+ S STCODE=$S(TERM="VA-MST DECLINES REPORT":"D",TERM="VA-MST NEGATIVE REPORT":"N",TERM="VA-MST POSITIVE REPORT":"Y",1:"U")
+ Q STCODE
+ ;
+ ;====================================================
+SYNCH ;Synchronize the MST history file.
+ N INID,LTIME,NUMUPD,START,TEMP
+ ;STIME is passed from QUE via ZTSAVE.
+ D UPDSTAT(.NUMUPD,.START)
+ ;If the initial sync data has been stored then update the daily
+ ;data.
+ S INID=+$P($G(^PXRM(800,1,"MST")),U,1)
+ I INID>0 D
+ . S $P(^PXRM(800,1,"MST"),U,3)=$$NOW^XLFDT
+ . S $P(^PXRM(800,1,"MST"),U,4)=NUMUPD
+ . S $P(^PXRM(800,1,"MST"),U,6)=START
+ E  D
+ . S $P(^PXRM(800,1,"MST"),U,1)=$$NOW^XLFDT
+ . S $P(^PXRM(800,1,"MST"),U,2)=NUMUPD
+ . S $P(^PXRM(800,1,"MST"),U,5)=START
+ ;
+ ;Cleanup the task stuff.
+ I STIME=-1 S ZTREQ="@" Q
+ E  D
+ . S TEMP=$G(^PXRM(800,1,"MST"))
+ . S LTIME=+$P(TEMP,U,3)
+ . I LTIME=0 S LTIME=+$P(TEMP,U,1)
+ .;Adding STIME sets the new starting time at exactly one day following
+ .;the previous starting time.
+ . S $P(ZTREQ,U,1)=$P(LTIME,".",1)+STIME
+ Q
+ ;
+ ;====================================================
+SYNREP ;Provide a report of the synchronization data.
+ N EDTIME,EITIME,IDATE,LDATE,NIUPD,NLUPD,TEMP
+ S TEMP=$G(^PXRM(800,1,"MST"))
+ S IDATE=$$FMTE^XLFDT($P(TEMP,U,1))
+ I IDATE=0 S IDATE="none"
+ S NIUPD=$P(TEMP,U,2)
+ S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),2)
+ S LDATE=$$FMTE^XLFDT($P(TEMP,U,3))
+ I LDATE=0 S LDATE="none"
+ S NLUPD=$P(TEMP,U,4)
+ S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),2)
+ W !!,"Clinical Reminders MST Synchronization Report"
+ W !,"---------------------------------------------"
+ W !,"Initial synchronization date: ",IDATE
+ W !,"Number of updates made: ",NIUPD
+ I EITIME>60 D
+ . S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),3)
+ . W !,"Elapsed time: ",EITIME
+ E  W !,"Elapsed time: ",EITIME," secs"
+ W !!,"Last daily synchronization date: ",LDATE
+ W !,"Number of updates made: ",NLUPD
+ I EDTIME>60 D
+ . S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),3)
+ . W !,"Elapsed time: ",EDTIME
+ E  W !,"Elapsed time: ",EDTIME," secs"
+ Q
+ ;
+ ;====================================================
+UPDATE(DFN,VISIT,SOURCE,STCODE,TYPE) ;Make an update to the MST History file.
+ N DATE,MSTDATE,PROV,STAT,TEMP,UPDSTAT,VPRVIEN
+ S UPDSTAT=-1
+ ;If the update is because of a protocol event use NOW for the
+ ;date/time. If it is being done as part of a synchronization use
+ ;the date the visit was created.
+ S DATE=$S(TYPE="PROTOCOL":$$NOW^XLFDT,1:$P($G(^AUPNVSIT(VISIT,0)),U,2))
+ ;If the date does not contain the time use noon.
+ I DATE'["." S DATE=DATE_".12"
+ S STAT=$$GETSTAT^DGMSTAPI(DFN)
+ S MSTDATE=$S($P(STAT,U,1)>0:$P(STAT,U,3),1:0)
+ I DATE>MSTDATE D
+ .;Determine the provider.
+ . S TEMP=$P(SOURCE,";",2)_$P(SOURCE,";",1)_",12)"
+ . S PROV=$P($G(@TEMP),U,4)
+ . I PROV="" D
+ ..;DBIA #2316
+ .. S VPRVIEN=+$O(^AUPNVPRV("AD",VISIT,""))
+ .. I VPRVIEN>0 S PROV=$P(^AUPNVPRV(VPRVIEN,0),U,1)
+ . S UPDSTAT=$$NEWSTAT^DGMSTAPI(DFN,STCODE,DATE,PROV)
+ . I +UPDSTAT=-1 D
+ .. N FN,GBL,IEN,NAME,TARGET,XMSUB,VADM
+ .. K ^TMP("PXRMXMZ",$J)
+ .. S XMSUB="CLINICAL REMINDER MST UPDATE PROBLEM"
+ .. S ^TMP("PXRMXMZ",$J,1,0)="NEWSTAT^DGMSTAPI returned the following error:"
+ .. S ^TMP("PXRMXMZ",$J,2,0)=$P(UPDSTAT,U,2)
+ .. S ^TMP("PXRMXMZ",$J,3,0)="The following data was passed to NEWSTAT^DGMSTAPI"
+ .. S ^TMP("PXRMXMZ",$J,4,0)="DFN = "_DFN
+ .. S ^TMP("PXRMXMZ",$J,5,0)="Status code = "_STCODE
+ .. S ^TMP("PXRMXMZ",$J,6,0)="Date = "_DATE
+ .. S ^TMP("PXRMXMZ",$J,7,0)="Provider = "_PROV
+ .. S ^TMP("PXRMXMZ",$J,8,0)="Data source = "_SOURCE
+ .. S ^TMP("PXRMXMZ",$J,9,0)="This corresponds to the following:"
+ .. D DEM^VADPT
+ .. S ^TMP("PXRMXMZ",$J,10,0)="Patient = "_VADM(1)
+ .. S ^TMP("PXRMXMZ",$J,11,0)="SSN = "_$P(VADM(2),U,2)
+ .. S ^TMP("PXRMXMZ",$J,12,0)="MST Status = "_$$EXTERNAL^DILFD(29.11,3,"",STCODE)
+ .. S ^TMP("PXRMXMZ",$J,13,0)="Date = "_$$FMTE^XLFDT(DATE,"5Z")
+ .. S TEMP=$S(PROV="":"Unknown",1:TEMP=$$GET1^DIQ(200,PROV,.01,"","",""))
+ .. I TEMP="" S TEMP="Unknown"
+ .. S ^TMP("PXRMXMZ",$J,14,0)="Provider = "_TEMP
+ .. S GBL=$P($P(SOURCE,";",2),"(",1)
+ .. S TEMP=GBL_"(0)"
+ .. S FN=+$P(@TEMP,U,2)
+ .. S TEMP=GBL_"("_$P(SOURCE,";",1)_",0)"
+ .. S TEMP=$G(@TEMP)
+ .. S IEN=$P(TEMP,U,1)
+ .. D FIELD^DID(FN,.01,"N","POINTER","TARGET")
+ .. S GBL="^"_$P(TARGET("POINTER"),"(",1)
+ .. S TEMP=GBL_"(0)"
+ .. S FN=$P(@TEMP,U,1)
+ .. S TEMP=GBL_"("_IEN_",0)"
+ .. S NAME=$P(@TEMP,U,1)
+ .. S ^TMP("PXRMXMZ",$J,14,0)="Data type = "_FN
+ .. S ^TMP("PXRMXMZ",$J,15,0)="Name = "_NAME
+ .. D SEND^PXRMMSG(XMSUB)
+ Q UPDSTAT
+ ;
+ ;====================================================
+UPDPAT(DFN,VISIT,VFL) ;Update the MST history file for a single patient
+ ;using term mappings. Called from DATACHG^PXRMPINF which is invoked
+ ;by the protocol PXK VISIT DATA EVENT.
+ N AFTER,BEFORE,DGBL,SP,STCODE,SIEN,SOURCE
+ N TEMP,TERM,TERMIEN,VF
+ ;Search all the MST terms to build patient lists.
+ F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D
+ . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,""))
+ . S VF=""
+ . F  S VF=$O(VFL(VF)) Q:VF=""  D
+ .. I VFL(VF)=U Q
+ .. S DGBL=$P(VFL(VF),U,1)
+ .. I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL)) Q
+ .. S SIEN=""
+ .. F  S SIEN=$O(^TMP("PXKCO",$J,VISIT,VF,SIEN)) Q:SIEN=""  D
+ ... S AFTER=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"AFTER"))
+ ... S BEFORE=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"BEFORE"))
+ ... I AFTER=BEFORE Q
+ ... S SP=$P(AFTER,U,1)
+ ... I SP="" Q
+ ... I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL,SP)) Q
+ ... S SOURCE=SIEN_";^"_$P(VFL(VF),U,2)
+ ...;The status code depends on the term name.
+ ... S STCODE=$$STCODE(TERM)
+ ... S TEMP=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"PROTOCOL")
+ Q
+ ;
+ ;====================================================
+UPDSTAT(NUMUPD,START) ;Update the MST history file using term mappings.
+ N DAS,DATA,DFN,FILENUM,FINDPA,INDEX,ITEM,NOCC,STCODE,SOURCE
+ N TEMP,TERM,TERMARR,TERMIEN,UPDSTAT,VDATE,VISIT
+ S FINDPA=""
+ ;Set the start time for the synchronization.
+ S START=$$NOW^XLFDT
+ S INDEX="PXRM_MST_LIST"
+ S NUMUPD=0
+ ;Search all the MST terms to build patient lists. Only V file data
+ ;is used for the update.
+ F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D
+ . K TERMARR,^TMP($J,INDEX)
+ .;The status code depends on the term name.
+ . S STCODE=$$STCODE(TERM)
+ . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,""))
+ . I TERMIEN="" Q
+ . D TERM^PXRMLDR(TERMIEN,.TERMARR)
+ . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,INDEX)
+ . S DFN=0
+ . F  S DFN=+$O(^TMP($J,INDEX,1,DFN)) Q:DFN=0  D
+ .. S ITEM=""
+ .. F  S ITEM=$O(^TMP($J,INDEX,1,DFN,ITEM)) Q:ITEM=""  D
+ ... S NOCC=0
+ ... F  S NOCC=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC)) Q:NOCC=""  D
+ .... S FILENUM=""
+ .... F  S FILENUM=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM)) Q:FILENUM=""  D
+ ..... S TEMP=^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM)
+ ..... S DAS=$P(TEMP,U,1)
+ ..... K DATA
+ ..... D GETDATA^PXRMDATA(FILENUM,DAS,.DATA)
+ ..... S VISIT=$G(DATA("VISIT"))
+ ..... I VISIT="" Q
+ ..... S SOURCE=DAS_";"_^PXRMINDX(FILENUM,"GLOBAL NAME")
+ ..... S UPDSTAT=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"SYNCH")
+ ..... I UPDSTAT'=-1 S NUMUPD=NUMUPD+1
+ K ^TMP($J,INDEX)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m

@@ -1 @@
-PXRMOUTC        ; SLC/PKR - Clinical Maintenance output. ;07/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;================================================
-CM(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL)     ;Prepare the 
-        ;clinical maintenance output.
-        N IND,JND,FIDATA,FINDING,FLIST,FTYPE
-        N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
-        N TEMP,TEXT
-        S NTXT=0
-        ;Check for a dead patient
-        I +$G(PXRMPDEM("DOD"))>0 D
-        . S TEMP=$$FMTE^XLFDT(PXRMPDEM("DOD"),"5DZ")
-        . S TEXT="Patient is deceased, date of death: "_TEMP
-        . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
-        ;Display the frequency information only if there is resolution logic.
-        I RESLOGIC'="" D FREQ(.DEFARR,.NTXT,.TEXT)
-        ;Output the AGE match/no match text.
-        D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT)
-        ;Process the findings in the order: patient cohort, resolution,
-        ;age, and informational.
-        M FIDATA=FIEVAL
-        F FTYPE="PCL","RES","AGE","INFO" D
-        . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42))
-        .;Output the general logic text.
-        . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT)
-        . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT)
-        .;Process the findings for each type.
-        . K TEXT
-        . S (NHDR,NFLINES)=0
-        . S NUM=+$P(LIST,U,1)
-        . S FLIST=$P(LIST,U,2)
-        . F IND=1:1:NUM D
-        .. S FINDING=$P(FLIST,";",IND)
-        ..;No output for age or sex findings.
-        .. I (FINDING="AGE")!(FINDING="SEX") Q
-        ..;Make sure each finding is processed only once.
-        .. I '$D(FIDATA(FINDING)) Q
-        .. K IFIEVAL
-        .. ;I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
-        .. ;E  S IFIEVAL=0
-        .. I FIEVAL(FINDING) D
-        ... M IFIEVAL=FIEVAL(FINDING)
-        ...;Remove any false occurrences so they are not displayed.
-        ... S JND=0
-        ... F  S JND=+$O(IFIEVAL(JND)) Q:JND=0  K:'IFIEVAL(JND) IFIEVAL(JND)
-        .. E  S IFIEVAL=0
-        ..;If the finding is false all we need to do is process the not found
-        ..;text. If it is true we also need to output the finding information.
-        .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT)
-        ..;Output the found/not found text for the finding.
-FNF     .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT)
-        ..;Make sure each finding is processed only once.
-        .. K FIDATA(FINDING)
-        .;
-        .;If there was any text for this finding type create a header.
-        . D HEADER(FTYPE,NFLINES,RESDATE,.NHDR,.HDR)
-        .;Output the header and the finding text.
-        . D ADDTXTA^PXRMOUTU(1,PXRMRM,.NTXT,NHDR,.HDR)
-        . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT)
-        ;Output INFO nodes
-        D INFO^PXRMOUTU(PXRMITEM,.NTXT)
-        Q
-        ;
-        ;================================================
-FOUT(INDENT,IFIEVAL,NLINES,TEXT)        ;Do output for individual findings 
-        ;in the FINDING array.
-        I $D(IFIEVAL("TERM")) D OUTPUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q
-        N FTYPE
-        S FTYPE=$P(IFIEVAL("FINDING"),U,1)
-        S FTYPE=$P(FTYPE,";",2)
-        I FTYPE="AUTTEDT(" D OUTPUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTEXAM(" D OUTPUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTHF(" D OUTPUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTIMM(" D OUTPUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTSK(" D OUTPUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="GMRD(120.51," D OUTPUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="LAB(60," D OUTPUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="ORD(101.43," D OUTPUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PS(50.605," D OUTPUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PSDRUG(" D OUTPUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PSNDF(50.6," D OUTPUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXD(811.2," D OUTPUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXRMD(802.4," D OUTPUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXRMD(810.9," D OUTPUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXRMD(811.4," D OUTPUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="RAMIS(71," D OUTPUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="YTT(601.71," D OUTPUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        Q
-        ;
-        ;================================================
-FREQ(DEFARR,NTXT,TEXT)  ;Display the frequency information.
-        N FREQ,TEMP
-        ;If there was a custom date due print out that information.
-        I $D(^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")) D
-        . S TEMP=^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")
-        . S TEXT=$$OUTPUT^PXRMCDUE(TEMP,.DEFARR)
-        . I DEFARR(31)["AGE" D
-        .. S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG"))
-        .. I TEMP'="" S TEXT=TEXT_" Applicable"_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"."
-        . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
-        E  D
-        . S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG"))
-        . I TEMP'="" D
-        .. S FREQ=$P(TEMP,U,1)
-        .. S TEXT=$$FMTFREQ^PXRMAGE(FREQ)
-        .. I FREQ=-1 S TEXT=TEXT_" for this patient."
-        .. I DEFARR(31)["AGE",FREQ'=-1 S TEXT=TEXT_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"."
-        .. D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
-        Q
-        ;
-        ;================================================
-HEADER(FTYPE,NLINES,RESDATE,NHDR,HDR)   ;Create a finding header.
-        I FTYPE="RES" D  Q
-        . I +RESDATE'=0 D  Q
-        .. S HDR(2)="Resolution: Last done "_$$EDATE^PXRMDATE(RESDATE)
-        .. S NHDR=2
-        .. S HDR(1)="\\"
-        . I '$D(HDR(2)),NLINES>0 D
-        .. S HDR(2)="Resolution:"
-        .. S NHDR=2
-        .. S HDR(1)="\\"
-        ;
-        I NLINES=0 Q
-        I FTYPE="PCL" D  Q
-        . S NHDR=2
-        . S HDR(1)="\\"
-        . S HDR(2)="Cohort:"
-        ;
-        I FTYPE="AGE" D  Q
-        . S NHDR=2
-        . S HDR(1)="\\"
-        . S HDR(2)="Age/Frequency:"
-        ;
-        I FTYPE="INFO" D  Q
-        . S NHDR=2
-        . S HDR(1)="\\"
-        . S HDR(2)="Information:"
-        Q
-        ;
+PXRMOUTC ; SLC/PKR - Clinical Maintenance output. ;10/07/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;================================================
+CM(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL) ;Prepare the 
+ ;clinical maintenance output.
+ N IND,FIDATA,FINDING,FLIST,FTYPE
+ N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
+ N TEMP,TEXT
+ S NTXT=0
+ ;Check for a dead patient
+ I +$G(PXRMPDEM("DOD"))>0 D
+ . S TEMP=$$FMTE^XLFDT(PXRMPDEM("DOD"),"5DZ")
+ . S TEXT="Patient is deceased, date of death: "_TEMP
+ . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
+ ;Display the frequency information only if there is resolution logic.
+ I RESLOGIC'="" D FREQ(.DEFARR,.NTXT,.TEXT)
+ ;Output the AGE match/no match text.
+ D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT)
+ ;Process the findings in the order: patient cohort, resolution,
+ ;age, and informational.
+ M FIDATA=FIEVAL
+ F FTYPE="PCL","RES","AGE","INFO" D
+ . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42))
+ .;Output the general logic text.
+ . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT)
+ . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT)
+ .;Process the findings for each type.
+ . K TEXT
+ . S (NHDR,NFLINES)=0
+ . S NUM=+$P(LIST,U,1)
+ . S FLIST=$P(LIST,U,2)
+ . F IND=1:1:NUM D
+ .. S FINDING=$P(FLIST,";",IND)
+ ..;No output for age or sex findings.
+ .. I (FINDING="AGE")!(FINDING="SEX") Q
+ ..;Make sure each finding is processed only once.
+ .. I '$D(FIDATA(FINDING)) Q
+ .. K IFIEVAL
+ .. I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
+ .. E  S IFIEVAL=0
+ ..;If the finding is false all we need to do is process the not found
+ ..;text. If it is true we also need to output the finding information.
+ .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT)
+ ..;Output the found/not found text for the finding.
+FNF .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT)
+ ..;Make sure each finding is processed only once.
+ .. K FIDATA(FINDING)
+ .;
+ .;If there was any text for this finding type create a header.
+ . D HEADER(FTYPE,NFLINES,RESDATE,.NHDR,.HDR)
+ .;Output the header and the finding text.
+ . D ADDTXTA^PXRMOUTU(1,PXRMRM,.NTXT,NHDR,.HDR)
+ . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT)
+ ;Output INFO nodes
+ D INFO^PXRMOUTU(PXRMITEM,.NTXT)
+ Q
+ ;
+ ;================================================
+FOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Do output for individual findings 
+ ;in the FINDING array.
+ I $D(IFIEVAL("TERM")) D OUTPUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q
+ N FTYPE
+ S FTYPE=$P(IFIEVAL("FINDING"),U,1)
+ S FTYPE=$P(FTYPE,";",2)
+ I FTYPE="AUTTEDT(" D OUTPUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTEXAM(" D OUTPUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTHF(" D OUTPUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTIMM(" D OUTPUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTSK(" D OUTPUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="GMRD(120.51," D OUTPUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="LAB(60," D OUTPUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="ORD(101.43," D OUTPUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PS(50.605," D OUTPUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PSDRUG(" D OUTPUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PSNDF(50.6," D OUTPUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXD(811.2," D OUTPUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXRMD(802.4," D OUTPUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXRMD(810.9," D OUTPUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXRMD(811.4," D OUTPUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="RAMIS(71," D OUTPUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="YTT(601," D OUTPUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ Q
+ ;
+ ;================================================
+FREQ(DEFARR,NTXT,TEXT) ;Display the frequency information.
+ N FREQ,TEMP
+ ;If there was a custom date due print out that information.
+ I $D(^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")) D
+ . S TEMP=^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")
+ . S TEXT=$$OUTPUT^PXRMCDUE(TEMP,.DEFARR)
+ . I DEFARR(31)["AGE" D
+ .. S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG"))
+ .. I TEMP'="" S TEXT=TEXT_" Applicable"_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"."
+ . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
+ E  D
+ . S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG"))
+ . I TEMP'="" D
+ .. S FREQ=$P(TEMP,U,1)
+ .. S TEXT=$$FMTFREQ^PXRMAGE(FREQ)
+ .. I FREQ=-1 S TEXT=TEXT_" for this patient."
+ .. I DEFARR(31)["AGE",FREQ'=-1 S TEXT=TEXT_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"."
+ .. D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
+ Q
+ ;
+ ;================================================
+HEADER(FTYPE,NLINES,RESDATE,NHDR,HDR) ;Create a finding header.
+ I FTYPE="RES" D  Q
+ . I +RESDATE'=0 D  Q
+ .. S HDR(2)="Resolution: Last done "_$$EDATE^PXRMDATE(RESDATE)
+ .. S NHDR=2
+ .. S HDR(1)="\\"
+ . I '$D(HDR(2)),NLINES>0 D
+ .. S HDR(2)="Resolution:"
+ .. S NHDR=2
+ .. S HDR(1)="\\"
+ ;
+ I NLINES=0 Q
+ I FTYPE="PCL" D  Q
+ . S NHDR=2
+ . S HDR(1)="\\"
+ . S HDR(2)="Cohort:"
+ ;
+ I FTYPE="AGE" D  Q
+ . S NHDR=2
+ . S HDR(1)="\\"
+ . S HDR(2)="Age/Frequency:"
+ ;
+ I FTYPE="INFO" D  Q
+ . S NHDR=2
+ . S HDR(1)="\\"
+ . S HDR(2)="Information:"
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m

@@ -1 @@
-PXRMOUTM        ; SLC/PKR - MyHealtheVet output. ;07/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;================================================
-FOUT(INDENT,IFIEVAL,NLINES,TEXT)        ;Do output for individual findings 
-        ;in the FINDING array.
-        I $D(IFIEVAL("TERM")) D MHVOUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q
-        N FTYPE
-        S FTYPE=$P(IFIEVAL("FINDING"),U,1)
-        S FTYPE=$P(FTYPE,";",2)
-        I FTYPE="AUTTEDT(" D MHVOUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTEXAM(" D MHVOUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTHF(" D MHVOUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTIMM(" D MHVOUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="AUTTSK(" D MHVOUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="GMRD(120.51," D MHVOUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="LAB(60," D MHVOUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="ORD(101.43," D MHVOUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PS(50.605," D MHVOUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PSDRUG(" D MHVOUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PSNDF(50.6," D MHVOUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXD(811.2," D MHVOUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXRMD(802.4," D MHVOUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXRMD(810.9," D MHVOUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="PXRMD(811.4," D MHVOUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="RAMIS(71," D MHVOUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        I FTYPE="YTT(601.71," D MHVOUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
-        Q
-        ;
-        ;================================================
-MHVC(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL)   ;Prepare the 
-        ;MyHealtheVet combined output.
-        N PNAME,RIEN
-        S RIEN=DEFARR("IEN")
-        S PNAME=$O(^TMP("PXRHM",$J,RIEN,""))
-        S ^TMP("PXRMMHVC",$J,RIEN,"STATUS")=^TMP("PXRHM",$J,RIEN,PNAME)
-        D MHVD(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0)
-        M ^TMP("PXRMMHVC",$J,RIEN,"DETAIL")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT")
-        K ^TMP("PXRHM",$J,RIEN,PNAME,"TXT")
-        D MHVS(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0)
-        M ^TMP("PXRMMHVC",$J,RIEN,"SUMMARY")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT")
-        K ^TMP("PXRHM",$J,RIEN,PNAME)
-        Q
-        ;
-        ;================================================
-MHVD(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB)       ;Prepare the 
-        ;MyHealtheVet detailed output.
-        N IND,JND,FIDATA,FINDING,FLIST,FTYPE
-        N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
-        N TEXT
-        S NTXT=0
-        ;Output the AGE match/no match text.
-        D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT)
-        ;Process the findings in the order: patient cohort, resolution,
-        ;age, and informational.
-        M FIDATA=FIEVAL
-        F FTYPE="PCL","RES","AGE","INFO" D
-        . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42))
-        .;Output the general logic text.
-        . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT)
-        . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT)
-        .;Process the findings for each type.
-        . K TEXT
-        . S (NHDR,NFLINES)=0
-        . S NUM=+$P(LIST,U,1)
-        . S FLIST=$P(LIST,U,2)
-        . F IND=1:1:NUM D
-        .. S FINDING=$P(FLIST,";",IND)
-        ..;No output for age or sex findings.
-        .. I (FINDING="AGE")!(FINDING="SEX") Q
-        ..;Make sure each finding is processed only once.
-        .. I '$D(FIDATA(FINDING)) Q
-        .. K IFIEVAL
-        .. ;I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
-        .. ;E  S IFIEVAL=0
-        .. I FIEVAL(FINDING) D
-        ... M IFIEVAL=FIEVAL(FINDING)
-        ...;Remove any false occurrences so they are not displayed.
-        ... S JND=0
-        ... F  S JND=+$O(IFIEVAL(JND)) Q:JND=0  K:'IFIEVAL(JND) IFIEVAL(JND)
-        .. E  S IFIEVAL=0
-        ..;Output the found/not found text for the finding.
-        .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT)
-        ..;If the finding is true output the finding information.
-        .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT)
-        ..;Make sure each finding is processed only once.
-        .. K FIDATA(FINDING)
-        .;
-        .;If there was any text for this finding type create a header.
-        .;Output the header and the finding text.
-        . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT)
-        I WEB D WEB(DEFARR("IEN"),.NTXT)
-        Q
-        ;
-        ;================================================
-MHVS(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB)       ;Prepare the 
-        ;MyHealtheVet summary output.
-        N NTXT
-        S NTXT=0
-        D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,"PCL","S",.DEFARR,.NTXT)
-        I $P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,"RES","S",.DEFARR,.NTXT)
-        I WEB D WEB(DEFARR("IEN"),.NTXT)
-        Q
-        ;
-        ;================================================
-WEB(RIEN,NTXT)  ;Output the web site information.
-        N DES,IEN,IND,NL,TEXT,TITLE,URL
-        I '$D(^PXD(811.9,RIEN,50)) Q
-        S TEXT="\\ Please check these web sites for more information:\\"
-        D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
-        S IEN=0
-        F  S IEN=+$O(^PXD(811.9,RIEN,50,IEN)) Q:IEN=0  D
-        . S TEXT=$G(^PXD(811.9,RIEN,50,IEN,0))
-        . S URL=$P(TEXT,U,1)
-        . I URL="" Q
-        . S TITLE=$P(TEXT,U,2)
-        . S DES=$D(^PXD(811.9,RIEN,50,IEN,1))
-        . S TEXT(1)="Web Site: "_TITLE_"\\"
-        . S TEXT(2)="URL: "_URL_$S('DES:"\\",1:"")
-        . D ADDTXTA^PXRMOUTU(2,PXRMRM,.NTXT,2,.TEXT)
-        .;If there is a description output it.
-        . I 'DES Q
-        . K TEXT
-        . S (IND,NL)=0
-        .  F  S IND=+$O(^PXD(811.9,RIEN,50,IEN,1,IND)) Q:IND=0  D
-        .. S NL=NL+1
-        .. S TEXT(NL)=^PXD(811.9,RIEN,50,IEN,1,IND,0)
-        . S TEXT(NL)=TEXT(NL)_"\\"
-        . D ADDTXTA^PXRMOUTU(3,PXRMRM,.NTXT,NL,.TEXT)
-        Q
-        ;
+PXRMOUTM ; SLC/PKR - MyHealtheVet output. ;10/12/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;================================================
+FOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Do output for individual findings 
+ ;in the FINDING array.
+ I $D(IFIEVAL("TERM")) D MHVOUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q
+ N FTYPE
+ S FTYPE=$P(IFIEVAL("FINDING"),U,1)
+ S FTYPE=$P(FTYPE,";",2)
+ I FTYPE="AUTTEDT(" D MHVOUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTEXAM(" D MHVOUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTHF(" D MHVOUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTIMM(" D MHVOUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="AUTTSK(" D MHVOUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="GMRD(120.51," D MHVOUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="LAB(60," D MHVOUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="ORD(101.43," D MHVOUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PS(50.605," D MHVOUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PSDRUG(" D MHVOUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PSNDF(50.6," D MHVOUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXD(811.2," D MHVOUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXRMD(802.4," D MHVOUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXRMD(810.9," D MHVOUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="PXRMD(811.4," D MHVOUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="RAMIS(71," D MHVOUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="YTT(601," D MHVOUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ Q
+ ;
+ ;================================================
+MHVC(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL) ;Prepare the 
+ ;MyHealtheVet combined output.
+ N PNAME,RIEN
+ S RIEN=DEFARR("IEN")
+ S PNAME=$O(^TMP("PXRHM",$J,RIEN,""))
+ S ^TMP("PXRMMHVC",$J,RIEN,"STATUS")=^TMP("PXRHM",$J,RIEN,PNAME)
+ D MHVD(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0)
+ M ^TMP("PXRMMHVC",$J,RIEN,"DETAIL")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT")
+ K ^TMP("PXRHM",$J,RIEN,PNAME,"TXT")
+ D MHVS(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0)
+ M ^TMP("PXRMMHVC",$J,RIEN,"SUMMARY")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT")
+ K ^TMP("PXRHM",$J,RIEN,PNAME)
+ Q
+ ;
+ ;================================================
+MHVD(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the 
+ ;MyHealtheVet detailed output.
+ N IND,FIDATA,FINDING,FLIST,FTYPE
+ N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
+ N TEXT
+ S NTXT=0
+ ;Output the AGE match/no match text.
+ D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT)
+ ;Process the findings in the order: patient cohort, resolution,
+ ;age, and informational.
+ M FIDATA=FIEVAL
+ F FTYPE="PCL","RES","AGE","INFO" D
+ . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42))
+ .;Output the general logic text.
+ . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT)
+ . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT)
+ .;Process the findings for each type.
+ . K TEXT
+ . S (NHDR,NFLINES)=0
+ . S NUM=+$P(LIST,U,1)
+ . S FLIST=$P(LIST,U,2)
+ . F IND=1:1:NUM D
+ .. S FINDING=$P(FLIST,";",IND)
+ ..;No output for age or sex findings.
+ .. I (FINDING="AGE")!(FINDING="SEX") Q
+ ..;Make sure each finding is processed only once.
+ .. I '$D(FIDATA(FINDING)) Q
+ .. K IFIEVAL
+ .. I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
+ .. E  S IFIEVAL=0
+ ..;Output the found/not found text for the finding.
+ .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT)
+ ..;If the finding is true output the finding information.
+ .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT)
+ ..;Make sure each finding is processed only once.
+ .. K FIDATA(FINDING)
+ .;
+ .;If there was any text for this finding type create a header.
+ .;Output the header and the finding text.
+ . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT)
+ I WEB D WEB(DEFARR("IEN"),.NTXT)
+ Q
+ ;
+ ;================================================
+MHVS(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the 
+ ;MyHealtheVet summary output.
+ N NTXT
+ S NTXT=0
+ D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,"PCL","S",.DEFARR,.NTXT)
+ I $P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,"RES","S",.DEFARR,.NTXT)
+ I WEB D WEB(DEFARR("IEN"),.NTXT)
+ Q
+ ;
+ ;================================================
+WEB(RIEN,NTXT) ;Output the web site information.
+ N DES,IEN,IND,NL,TEXT,TITLE,URL
+ I '$D(^PXD(811.9,RIEN,50)) Q
+ S TEXT="\\ Please check these web sites for more information:\\"
+ D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT)
+ S IEN=0
+ F  S IEN=+$O(^PXD(811.9,RIEN,50,IEN)) Q:IEN=0  D
+ . S TEXT=$G(^PXD(811.9,RIEN,50,IEN,0))
+ . S URL=$P(TEXT,U,1)
+ . I URL="" Q
+ . S TITLE=$P(TEXT,U,2)
+ . S DES=$D(^PXD(811.9,RIEN,50,IEN,1))
+ . S TEXT(1)="Web Site: "_TITLE_"\\"
+ . S TEXT(2)="URL: "_URL_$S('DES:"\\",1:"")
+ . D ADDTXTA^PXRMOUTU(2,PXRMRM,.NTXT,2,.TEXT)
+ .;If there is a description output it.
+ . I 'DES Q
+ . K TEXT
+ . S (IND,NL)=0
+ .  F  S IND=+$O(^PXD(811.9,RIEN,50,IEN,1,IND)) Q:IND=0  D
+ .. S NL=NL+1
+ .. S TEXT(NL)=^PXD(811.9,RIEN,50,IEN,1,IND,0)
+ . S TEXT(NL)=TEXT(NL)_"\\"
+ . D ADDTXTA^PXRMOUTU(3,PXRMRM,.NTXT,NL,.TEXT)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m

@@ -1 @@
-PXRMPARS        ; SLC/PJH - Edit PXRM(800 reminder parameters. ;04/02/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;called by protocol PXRM EDIT SITE DISCLAIMER
-        ;
-DISC(DA)        ;Edit default disclaimer
-        Q:'$$LOCK(DA)
-        N DIC,DIE,DR,Y
-        ;Edit
-        S DIC="^PXRM(800,",DIE=800,DR=2
-        D ^DIE
-        D FORMAT^PXRMDISC
-        Q
-        ;
-MH(DA)  ;Edit MH default Question Value
-        Q:'$$LOCK(DA)
-        N DIC,DIE,DR,Y
-        ;Edit
-        S DIE="^PXRM(800,",DR=17
-        D ^DIE
-        Q
-        ;
-        ;called by protocol PXRM EDIT WEB SITE
-        ;
-WEB(DA) ;Edit default web site
-        Q:'$$LOCK(DA)
-        ;Edit
-        N DTOUT,DUOUT
-        F  D  Q:$D(DUOUT)!$D(DTOUT)
-        .D WLIST,WSET,WURL(DA)
-        Q
-        ;
-WLIST   ;Display web sites
-        N FIRST,SUB,SUB1
-        S FIRST=1,SUB=""
-        F  S SUB=$O(^PXRM(800,DA,1,"B",SUB)) Q:SUB=""  D
-        .S SUB1=0
-        .F  S SUB1=$O(^PXRM(800,DA,1,"B",SUB,SUB1)) Q:'SUB1  D
-        ..I FIRST S FIRST=0 W !!,"Choose from:",!
-        ..W ?8,$P($G(^PXRM(800,DA,1,SUB1,0)),U),!
-        I FIRST W !!,"No default web sites defined",!
-        Q
-        ;
-WSET    ;Set node if not defined
-        S:'$D(^PXRM(800,DA,1,0)) ^PXRM(800,DA,1,0)="^800.04"
-        Q
-        ;
-WURL(IEN)       ;Edit individual URL
-        N DA,DIC,DIE,DR,Y
-        S DA(1)=IEN
-        S DIC="^PXRM(800,"_IEN_",1,"
-        S DIC(0)="QEAL"
-        S DIC("A")="Select URL: "
-        S DIC("P")="800.04"
-        D ^DIC I Y=-1 S DTOUT=1 Q
-        S DIE=DIC K DIC
-        S DA=+Y
-        ;Finding record fields
-        S DR=".01;.02;1"
-        ;Edit finding record
-        D ^DIE
-        I $D(Y) S DTOUT=1 Q
-        ;Check if deleted
-        I '$D(DA) Q
-        Q
-        ;
-LOCK(DA)        ;Lock the record
-        L +^PXRM(800,DA):0 I  Q 1
-        E  W !!,?5,"Another user is editing this file, try later" H 2 Q 0
-        ;
-UNLOCK(DA)      ;Unlock the record
-        L -^PXRM(800,DA)
-        Q
+PXRMPARS ; SLC/PJH - Edit PXRM(800 reminder parameters. ;06/14/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;called by protocol PXRM EDIT SITE DISCLAIMER
+ ;
+DISC(DA) ;Edit default disclaimer
+ Q:'$$LOCK(DA)
+ N DIC,DIE,DR,Y
+ ;Edit
+ S DIC="^PXRM(800,",DIE=800,DR=2
+ D ^DIE
+ D FORMAT^PXRMDISC
+ Q
+ ;
+ ;called by protocol PXRM EDIT WEB SITE
+ ;
+WEB(DA) ;Edit default web site
+ Q:'$$LOCK(DA)
+ ;Edit
+ N DTOUT,DUOUT
+ F  D  Q:$D(DUOUT)!$D(DTOUT)
+ .D WLIST,WSET,WURL(DA)
+ Q
+ ;
+WLIST ;Display web sites
+ N FIRST,SUB,SUB1
+ S FIRST=1,SUB=""
+ F  S SUB=$O(^PXRM(800,DA,1,"B",SUB)) Q:SUB=""  D
+ .S SUB1=0
+ .F  S SUB1=$O(^PXRM(800,DA,1,"B",SUB,SUB1)) Q:'SUB1  D
+ ..I FIRST S FIRST=0 W !!,"Choose from:",!
+ ..W ?8,$P($G(^PXRM(800,DA,1,SUB1,0)),U),!
+ I FIRST W !!,"No default web sites defined",!
+ Q
+ ;
+WSET ;Set node if not defined
+ S:'$D(^PXRM(800,DA,1,0)) ^PXRM(800,DA,1,0)="^800.04"
+ Q
+ ;
+WURL(IEN) ;Edit individual URL
+ N DA,DIC,DIE,DR,Y
+ S DA(1)=IEN
+ S DIC="^PXRM(800,"_IEN_",1,"
+ S DIC(0)="QEAL"
+ S DIC("A")="Select URL: "
+ S DIC("P")="800.04"
+ D ^DIC I Y=-1 S DTOUT=1 Q
+ S DIE=DIC K DIC
+ S DA=+Y
+ ;Finding record fields
+ S DR=".01;.02;1"
+ ;Edit finding record
+ D ^DIE
+ I $D(Y) S DTOUT=1 Q
+ ;Check if deleted
+ I '$D(DA) Q
+ Q
+ ;
+LOCK(DA) ;Lock the record
+ L +^PXRM(800,DA):0 I  Q 1
+ E  W !!,?5,"Another user is editing this file, try later" H 2 Q 0
+ ;
+UNLOCK(DA) ;Unlock the record
+ L -^PXRM(800,DA)
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m

@@ -1 @@
-PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;11/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-EN(PLIEN)       ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
-        N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
-        W @IOF
-        K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
-        S DELIM=0
-OPTION  ;
-        W !,"Select the items to include on the report."
-ADDSEL  D ADDSEL^PXRMPDRS(.DDATA,"ADD")
-        I $D(DTOUT)!$D(DUOUT) Q
-APPSEL  D APPSEL^PXRMPDRS(.DDATA,"APP")
-        I $D(DTOUT)!$D(DUOUT) G ADDSEL
-DEMSEL  D DEMSEL^PXRMPDRS(.DDATA,"DEM")
-        I $D(DTOUT)!$D(DUOUT) G APPSEL
-PFACSEL S DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
-        I $D(DTOUT)!$D(DUOUT) G DEMSEL
-        S DDATA("PFAC","LEN")=$S(DDATA("PFAC",0)=1:1,1:0)
-ELIGSEL D ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
-        I $D(DTOUT)!$D(DUOUT) G PFACSEL
-DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
-        I $D(DTOUT)!$D(DUOUT) G ELIGSEL
-INPSEL  D INPSEL^PXRMPDRS(.DDATA,"INP")
-        I $D(DTOUT)!$D(DUOUT) G DATASEL
-REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
-        I $D(DTOUT)!$D(DUOUT) G INPSEL
-        S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
-        I $D(DTOUT)!$D(DUOUT) G REMDATA
-        S DC=$S(DELIM:$$DELIMSEL^PXRMXSD,1:U)
-        I $D(DTOUT)!$D(DUOUT) G OPTION
-DEVICE  ;
-        N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
-        S %ZIS="M"
-        S DESC="Patient List Demographic Report"
-        S RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
-        S SAVE("DELIM")="",SAVE("DC")="",SAVE("PLIEN")=""
-        S SAVE("DDATA(")=""
-        S PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
-        I PXRMQUE'="" G EXIT
-        I $D(DTOUT)!$D(DUOUT) G EXIT
-        S DIR(0)="E" D ^DIR
-EXIT    D KVA^VADPT
-        K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
-        Q
-        ;
-GETPDATA(DELIM,DC,PLIEN,DDATA)  ;
-        N DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG
-        N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
-        N IEN,IND,JND,KND,LND
-        N LISTNAME,PIECE
-        N PDATA,PNAME,RIEN,TDATA
-        K ^TMP("PXRMPD",$J)
-        S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
-        S DCREAT=$P(^PXRMXP(810.5,PLIEN,0),U,4)
-        S GETDEM=$S(DDATA("DEM","LEN")>0:1,1:0)
-        S GETADD=$S(DDATA("ADD","LEN")>0:1,1:0)
-        S GETINP=$S(DDATA("INP","LEN")>0:1,1:0)
-        S GETELIG=$S(DDATA("ELIG","LEN")>0:1,1:0)
-        S GETAPP=$S(DDATA("APP","LEN")>0:1,1:0)
-        S GETFIND=$S(DDATA("FIND","LEN")>0:1,1:0)
-        S GETREM=$S(DDATA("REM","LEN")>0:1,1:0)
-        S IEN=0
-        F  S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0  D
-        . S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q
-        .;#DBIA 10035
-        . S PNAME=$P($G(^DPT(DFN,0)),U,1)
-        . I PNAME="" S PNAME="UNDEFINED"_DFN
-        . S ^TMP("PXRMPLN",$J,PNAME,DFN)=""
-        . S PDATA=""
-        . I GETDEM D
-        .. N VADM
-        .. D DEM^VADPT
-        .. F IND=1:1:DDATA("DEM","LEN") D
-        ... S JND=$P(DDATA("DEM"),",",IND)
-        ... S KND=0
-        ... F  S KND=$O(DDATA("DEM",JND,KND)) Q:KND=""  D
-        .... S PIECE=$P(DDATA("DEM",JND,KND),U,2)
-        .... S TDATA=$P(VADM(KND),U,PIECE)
-        .... S LND=""
-        .... F  S LND=$O(VADM(KND,LND)) Q:LND=""  D
-        ..... I TDATA'="" S TDATA=TDATA_"~"
-        ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
-        .... I KND=2,'DDATA("DEM","FULLSSN") S TDATA=$E(TDATA,8,11)
-        .... S $P(PDATA,U,KND)=TDATA
-        .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEM")=PDATA,PDATA=""
-        . I DDATA("PFAC",0)=1 D
-        ..;DBIA #1850
-        .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
-        .. I TDATA="" S TDATA="NONE"
-        .. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=TDATA
-        . I GETADD D
-        .. N VAPA
-        .. D ADD^VADPT
-        .. F IND=1:1:DDATA("ADD","LEN") D
-        ... S JND=$P(DDATA("ADD"),",",IND)
-        ... S KND=0
-        ... F  S KND=$O(DDATA("ADD",JND,KND)) Q:KND=""  D
-        .... S PIECE=$P(DDATA("ADD",JND,KND),U,2)
-        .... S TDATA=$P(VAPA(KND),U,PIECE)
-        .... S $P(PDATA,U,KND)=TDATA
-        .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=PDATA,PDATA=""
-        . I GETINP D
-        .. N VAIP
-        .. D INP^VADPT
-        .. F IND=1:1:DDATA("INP","LEN") D
-        ... S JND=$P(DDATA("INP"),",",IND)
-        ... S KND=0
-        ... F  S KND=$O(DDATA("INP",JND,KND)) Q:KND=""  D
-        .... S PIECE=$P(DDATA("INP",JND,KND),U,2)
-        .... S TDATA=$P(VAIN(KND),U,PIECE)
-        .... S $P(PDATA,U,KND)=TDATA
-        .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=PDATA,PDATA=""
-        . I GETELIG D
-        .. N VAEL
-        .. D ELIG^VADPT
-        .. F IND=1:1:DDATA("ELIG","LEN") D
-        ... S JND=$P(DDATA("ELIG"),",",IND)
-        ... S KND=0
-        ... F  S KND=$O(DDATA("ELIG",JND,KND)) Q:KND=""  D
-        .... S PIECE=$P(DDATA("ELIG",JND,KND),U,2)
-        .... S TDATA=$P(VAEL(KND),U,PIECE)
-        .... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
-        .... S $P(PDATA,U,KND)=TDATA
-        .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIG")=PDATA,PDATA=""
-        . D KVA^VADPT
-        . I GETREM D
-        .. S IND=0
-        .. F  S IND=$O(DDATA("REM","IEN",IND)) Q:IND=""  D
-        ... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
-        ... I PDATA="" Q
-        ... S RIEN=$P(PDATA,U,1)
-        ... S ^TMP("PXRMPLD",$J,DFN,"REM",RIEN)=PDATA,PDATA=""
-        . I GETFIND D
-        .. N DL
-        .. F IND=1:1:DDATA("FIND","LEN") D
-        ... S JND=$P(DDATA("FIND"),",",IND)
-        ... S DTYPE=DDATA("FIND",JND,JND)
-        ... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
-        ... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
-        ... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
-        ... S ^TMP("PXRMPLD",$J,DFN,"FIND",JND)=DATA
-        ;Get appointment data for all patients on the list.
-        I GETAPP D
-        . N ARRAY,COUNT
-        . S ARRAY(1)=DT,ARRAY(3)="I;R"
-        . S ARRAY(4)="^TMP($J,""PXRMPL""",ARRAY("FLDS")=""
-        . F IND=1:1:DDATA("APP","LEN") D
-        .. S JND=$P(DDATA("APP"),",",IND)
-        .. S KND=0
-        .. F  S KND=$O(DDATA("APP",JND,KND)) Q:KND=""  S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
-        . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
-        . S IND=0
-        . F  S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0  D
-        .. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
-        .. I DFN'="" S ^TMP($J,"PXRMPL",DFN)=""
-        . S COUNT=$$SDAPI^SDAMA301(.ARRAY)
-        . I COUNT=-1 D  Q
-        .. D APPERR^PXRMPDRS
-        .. S DDATA("APP","ERROR")=""
-        .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
-        . F IND=1:1:COUNT D
-        .. S DFN=""
-        .. F  S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN=""  D
-        ... S (JND,KND)=0
-        ... F  S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND=""  D
-        .... S DATE=0
-        .... F  S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE=""  D
-        ..... S KND=KND+1
-        ..... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE)
-        ..... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1))
-        ..... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
-        ..... S PDATA=PDATA_U_TDATA
-        ..... S ^TMP("PXRMPLD",$J,DFN,"APP",KND)=PDATA
-        . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
-        I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
-        I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.DDATA)
-        Q
-        ;
-LENGTH(STR,STR1)        ;
-        I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1
-        E  S STR=STR_U_STR1,STR1=""
-        Q
-        ;
-PAGE    ;
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
-        .S DIR(0)="E"
-        .W !
-        .D ^DIR K DIR
-        I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
-        W:$D(IOF) @IOF
-        S PAGE=PAGE+1
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF
-        Q
-        ;
+PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
+ N ADDDATA,APPDATA,ARRAY,BACK,CNT,DC,DEMDATA,DELIM,DIC,DIR,DTOUT,DUOUT
+ N ELIGDATA,IEN,INPDATA
+ N FINDDATA,NAME,NODE,PFACDATA,PTIEN
+ N QUIT,REMDATA
+ N X,Y,YESNO
+ W @IOF
+ K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
+ S BACK=0,DELIM=0,QUIT=0
+OPTION ;
+ W !,"Select the items to include on the report."
+ADDSEL D ADDSEL^PXRMPDRS(.ADDDATA)
+ I $D(DTOUT)!$D(DUOUT) Q
+APPSEL D APPSEL^PXRMPDRS(.APPDATA)
+ I $D(DTOUT)!$D(DUOUT) G ADDSEL
+DEMSEL D DEMSEL^PXRMPDRS(.DEMDATA)
+ I $D(DTOUT)!$D(DUOUT) G APPSEL
+PFACSEL S PFACDATA(0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
+ I $D(DTOUT)!$D(DUOUT) G DEMSEL
+ S PFACDATA("LEN")=$S(PFACDATA(0)=1:1,1:0)
+ELIGSEL D ELIGSEL^PXRMPDRS(.ELIGDATA)
+ I $D(DTOUT)!$D(DUOUT) G PFACSEL
+DATASEL D DATASEL^PXRMPDRS(PLIEN,.FINDDATA)
+ I $D(DTOUT)!$D(DUOUT) G ELIGSEL
+INPSEL D INPSEL^PXRMPDRS(.INPDATA)
+ I $D(DTOUT)!$D(DUOUT) G DATASEL
+REMDATA D REMSEL^PXRMPDRS(PLIEN,.REMDATA)
+ I $D(DTOUT)!$D(DUOUT) G INPSEL
+ S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
+ I $D(DTOUT)!$D(DUOUT) G REMDATA
+ I DELIM S DC=$$DELIMSEL^PXRMXSD
+ I $D(DTOUT)!$D(DUOUT) G OPTION
+DEVICE ;
+ N DIR,PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSAVE
+ S %ZIS="M"
+ S ZTDESC="Patient List Demographic"
+ S ZTRTN="GETDATA^PXRMPDR(DELIM,PLIEN,.DEMDATA,.PFACDATA,.ADDDATA,.INPDATA,.APPDATA,.FINDDATA,.REMDATA)"
+ S ZTSAVE("*")=""
+ S PXRMQUE=0
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
+ I PXRMQUE=1 G EXIT
+ I $D(DTOUT)!$D(DUOUT) G EXIT
+ ;
+ S DIR(0)="E" D ^DIR
+EXIT D KVA^VADPT
+ K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
+ Q
+ ;
+GETDATA(DELIM,PLIEN,DEMDATA,PFACDATA,ADDDATA,INPDATA,APPDATA,FINDDATA,REMDATA) ;
+ N DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG
+ N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
+ N IEN,IND,JND,KND,LND
+ N LISTNAME,PIECE
+ N PDATA,PNAME,RIEN,TDATA
+ K ^TMP("PXRMPD",$J)
+ S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
+ S DCREAT=$P(^PXRMXP(810.5,PLIEN,0),U,4)
+ S GETDEM=$S(DEMDATA("LEN")>0:1,1:0)
+ S GETADD=$S(ADDDATA("LEN")>0:1,1:0)
+ S GETINP=$S(INPDATA("LEN")>0:1,1:0)
+ S GETELIG=$S(ELIGDATA("LEN")>0:1,1:0)
+ S GETAPP=$S(APPDATA("LEN")>0:1,1:0)
+ S GETFIND=$S(FINDDATA("LEN")>0:1,1:0)
+ S GETREM=$S(REMDATA("LEN")>0:1,1:0)
+ S IEN=0
+ F  S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0  D
+ . S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q
+ .;#DBIA 10035
+ . S PNAME=$P($G(^DPT(DFN,0)),U,1)
+ . I PNAME="" S PNAME="UNDEFINED"_DFN
+ . S ^TMP("PXRMPLN",$J,PNAME,DFN)=""
+ . S PDATA=""
+ . I GETDEM D
+ .. N VADM
+ .. D DEM^VADPT
+ .. F IND=1:1:DEMDATA("LEN") D
+ ... S JND=$P(DEMDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(DEMDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(DEMDATA(JND,KND),U,2)
+ .... S TDATA=$P(VADM(KND),U,PIECE)
+ .... S LND=""
+ .... F  S LND=$O(VADM(KND,LND)) Q:LND=""  D
+ ..... I TDATA'="" S TDATA=TDATA_"~"
+ ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
+ .... I KND=2,'DEMDATA("FULLSSN") S TDATA=$E(TDATA,8,11)
+ .... S $P(PDATA,U,KND)=TDATA
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEMDATA")=PDATA,PDATA=""
+ . I PFACDATA(0)=1 D
+ ..;DBIA #1850
+ .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
+ .. I TDATA="" S TDATA="NONE"
+ .. S ^TMP("PXRMPLD",$J,DFN,"PFACDATA")=TDATA
+ . I GETADD D
+ .. N VAPA
+ .. D ADD^VADPT
+ .. F IND=1:1:ADDDATA("LEN") D
+ ... S JND=$P(ADDDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(ADDDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(ADDDATA(JND,KND),U,2)
+ .... S TDATA=$P(VAPA(KND),U,PIECE)
+ .... S $P(PDATA,U,KND)=TDATA
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADDDATA")=PDATA,PDATA=""
+ . I GETINP D
+ .. N VAIP
+ .. D INP^VADPT
+ .. F IND=1:1:INPDATA("LEN") D
+ ... S JND=$P(INPDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(INPDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(INPDATA(JND,KND),U,2)
+ .... S TDATA=$P(VAIN(KND),U,PIECE)
+ .... S $P(PDATA,U,KND)=TDATA
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INPDATA")=PDATA,PDATA=""
+ . I GETELIG D
+ .. N VAEL
+ .. D ELIG^VADPT
+ .. F IND=1:1:ELIGDATA("LEN") D
+ ... S JND=$P(ELIGDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(ELIGDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(ELIGDATA(JND,KND),U,2)
+ .... S TDATA=$P(VAEL(KND),U,PIECE)
+ .... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
+ .... S $P(PDATA,U,KND)=TDATA
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIGDATA")=PDATA,PDATA=""
+ . D KVA^VADPT
+ . I GETREM D
+ .. S IND=0
+ .. F  S IND=$O(REMDATA("IEN",IND)) Q:IND=""  D
+ ... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
+ ... I PDATA="" Q
+ ... S RIEN=$P(PDATA,U,1)
+ ... S ^TMP("PXRMPLD",$J,DFN,"REMDATA",RIEN)=PDATA,PDATA=""
+ . I GETFIND D
+ .. N DL
+ .. F IND=1:1:FINDDATA("LEN") D
+ ... S JND=$P(FINDDATA,",",IND)
+ ... S DTYPE=FINDDATA(JND,JND)
+ ... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
+ ... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
+ ... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
+ ... S ^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND)=DATA
+ ;Get appointment data for all patients on the list.
+ I GETAPP D
+ . N ARRAY,COUNT
+ . S ARRAY(1)=DT,ARRAY(3)="I;R"
+ . S ARRAY(4)="^TMP($J,""PXRMPL""",ARRAY("FLDS")=""
+ . F IND=1:1:APPDATA("LEN") D
+ .. S JND=$P(APPDATA,",",IND)
+ .. S KND=0
+ .. F  S KND=$O(APPDATA(JND,KND)) Q:KND=""  S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
+ . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
+ . S IND=0
+ . F  S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0  D
+ .. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
+ .. I DFN'="" S ^TMP($J,"PXRMPL",DFN)=""
+ . S COUNT=$$SDAPI^SDAMA301(.ARRAY)
+ . I COUNT=-1 D  Q
+ .. D APPERR^PXRMPDRS
+ .. S APPDATA("ERROR")=""
+ .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
+ . F IND=1:1:COUNT D
+ .. S DFN=""
+ .. F  S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN=""  D
+ ... S (JND,KND)=0
+ ... F  S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND=""  D
+ .... S DATE=0
+ .... F  S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE=""  D
+ ..... S KND=KND+1
+ ..... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE)
+ ..... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1))
+ ..... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
+ ..... S PDATA=PDATA_U_TDATA
+ ..... S ^TMP("PXRMPLD",$J,DFN,"APPDATA",KND)=PDATA
+ . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
+ I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
+ I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
+ Q
+ ;
+LENGTH(STR,STR1) ;
+ I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1
+ E  S STR=STR_U_STR1,STR1=""
+ Q
+ ;
+PAGE ;
+ I ($E(IOST)="C")&(IO=IO(0)) D
+ .S DIR(0)="E"
+ .W !
+ .D ^DIR K DIR
+ I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
+ W:$D(IOF) @IOF
+ S PAGE=PAGE+1
+ I $E(IOST)="C",IO=IO(0) W @IOF
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m

@@ -1 @@
-PXRMPDRP        ;SLC/AGP,PKR - Patient List Demographic report print routine ;11/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-ADDTXT(TEXT)    ;Accumulate text in ^TMP.
-        S LINCNT=LINCNT+1
-        S ^TMP("PXRMPDEM",$J,LINCNT)=TEXT
-        Q
-        ;
-APPHDR(DC,DDATA,SUB)    ;Build the appointment header.
-        I DDATA(SUB,"LEN")'>0 Q
-        N HDR,IND,JND,KND,LND,TEMP
-        S IND=0,HDR=""
-        F IND=1:1:DDATA(SUB,"MAX") D
-        . F JND=1:1:DDATA(SUB,"LEN") D
-        .. S KND=$P(DDATA(SUB),",",JND)
-        .. S LND=""
-        .. F  S LND=$O(DDATA(SUB,KND,LND)) Q:LND=""  D
-        ... S TEMP=$P(DDATA(SUB,KND,LND),U,1)
-        ... S HDR=HDR_TEMP_IND_DC
-        S DDATA(SUB,"HDR")=HDR
-        Q
-        ;
-APPPRINT(DFN,DDATA,SUB) ;Print appointment data.
-        N CLINIC,COUNT,DATE,HDR,IND,JND,KND,LINE,PCLINIC,PDATE,TEMP
-        S (PCLINIC,PDATE)=0
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . I JND=1 S PDATE=1
-        . I JND=2 S PCLINIC=1
-        S HDR=""
-        I PDATE S HDR=" "_$P(DDATA(SUB,1,1),U,1)
-        I PCLINIC S HDR=HDR_"   "_$P(DDATA(SUB,2,2),U,1)
-        D ADDTXT(" ")
-        D ADDTXT("Appointment Data")
-        D ADDTXT(HDR)
-        S COUNT=0
-        F  S COUNT=$O(^TMP("PXRMPLD",$J,DFN,"APP",COUNT)) Q:COUNT=""  D
-        . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APP",COUNT))
-        . S LINE=""
-        . I PDATE S LINE=LINE_$P(TEMP,U,1)
-        . I PCLINIC S LINE=LINE_"  "_$P(TEMP,U,2)
-        . D ADDTXT(LINE)
-        Q
-        ;
-DELIMHDR(DC,DDATA,SUB)  ;Build the delimited header for a data type.
-        I DDATA(SUB,"LEN")'>0 Q
-        N HDR,IND,JND,KND,LND,MAX,TEMP
-        S IND=0,HDR=""
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . S KND=""
-        . F  S KND=$O(DDATA(SUB,JND,KND)) Q:KND=""  D
-        .. S TEMP=$P(DDATA(SUB,JND,KND),U,1)
-        .. S MAX=$P(DDATA(SUB,JND,KND),U,3)
-        .. I MAX="" S HDR=HDR_TEMP_DC
-        .. I +MAX>0 F LND=1:1:MAX S HDR=HDR_TEMP_LND_DC
-        S DDATA(SUB,"HDR")=HDR
-        Q
-        ;
-DELIMPR(DC,PLIEN,DDATA) ;
-        ;Print the delimited report.
-        N DATALIST,DFN,IND,NDT,PNAME
-        S NDT=0
-        I DDATA("ADD","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ADD"
-        I DDATA("APP","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="APP"
-        I DDATA("DEM","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="DEM"
-        I DDATA("ELIG","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ELIG"
-        I DDATA("FIND","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="FIND"
-        I DDATA("INP","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="INP"
-        I DDATA("PFAC","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="PFAC"
-        I DDATA("REM","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="REM"
-        S DATALIST(0)=NDT
-        D TITLE(PLIEN,1)
-        ;Create the delimited header.
-        F IND=1:1:NDT D
-        . I DATALIST(IND)="ADD" D DELIMHDR(DC,.DDATA,"ADD") Q
-        . I DATALIST(IND)="APP" D APPHDR(DC,.DDATA,"APP") Q
-        . I DATALIST(IND)="DEM" D DELIMHDR(DC,.DDATA,"DEM") Q
-        . I DATALIST(IND)="ELIG" D DELIMHDR(DC,.DDATA,"ELIG") Q
-        . I DATALIST(IND)="FIND" D DELIMHDR(DC,.DDATA,"FIND") Q
-        . I DATALIST(IND)="INP" D DELIMHDR(DC,.DDATA,"INP") Q
-        . I DATALIST(IND)="PFAC" D PFACHDR(.DDATA,"PFAC")
-        . I DATALIST(IND)="REM" D REMHDR(DC,.DDATA,"REM") Q
-        D DELTITLE(DC,.DATALIST,.DDATA)
-        S PNAME=":"
-        F  S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME=""  D
-        . S DFN=""
-        . F  S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN=""  D
-        .. W !,PNAME_DC
-        .. F IND=1:1:NDT D
-        ... I DATALIST(IND)="ADD" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"ADD") Q
-        ... I DATALIST(IND)="APP" D PAPPDATA(DFN,DC,.DDATA,"APP") Q
-        ... I DATALIST(IND)="DEM" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"DEM") Q
-        ... I DATALIST(IND)="ELIG" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"ELIG") Q
-        ... I DATALIST(IND)="FIND" D PFINDATA(DFN,DC,.DDATA,"FIND") Q
-        ... I DATALIST(IND)="INP" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"INP") Q
-        ... I DATALIST(IND)="PFAC" D PFACDATA(DFN,.DDATA,"PFAC") Q
-        ... I DATALIST(IND)="REM" D PREMDATA(DFN,DC,.DDATA,"REM") Q
-        .. W "\\"
-        Q
-        ;
-DELTITLE(DC,DATALIST,DDATA)     ;Combine all the headers to create the delimited title.
-        W !,"PATIENT"_DC
-        N IND
-        F IND=1:1:DATALIST(0) W DDATA(DATALIST(IND),"HDR")
-        W "\\"
-        Q
-        ;
-FINDPR(DFN,DDATA,SUB)   ;Print finding information.
-        N IND,JND,LINE,TEMP
-        D ADDTXT(" ")
-        S LINE="Finding Data"
-        D ADDTXT(LINE)
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FIND",JND))
-        . I TEMP="" Q
-        . S LINE=" "_$P(DDATA(SUB,JND,JND),U,1)_": "_TEMP
-        . D ADDTXT(LINE)
-        Q
-        ;
-OUTPUT  ;Output the text.
-        N IND,LC,LO,VSIZE
-        S VSIZE=IOSL-2
-        S (LC,LO)=0
-        F IND=1:1:LINCNT D
-        . S LC=LC+1,LO=LO+1
-        . W !,^TMP("PXRMPDEM",$J,LC)
-        . I LO=VSIZE D
-        .. D PAGE
-        .. I $D(DTOUT)!$D(DUOUT) S IND=LINCNT Q
-        .. S LO=0
-        Q
-        ;
-PAGE    ;
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
-        . N DIR
-        . S DIR(0)="E"
-        . W !
-        . D ^DIR K DIR
-        I $D(DUOUT)!$D(DTOUT) Q
-        W:$D(IOF) @IOF
-        I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF
-        Q
-        ;
-PAPPDATA(DFN,DC,DDATA,SUB)      ;Print the delimited appointment data.
-        N IND,JND,KND,LINE,LND,PIECE,TEMP
-        I DDATA(SUB,"LEN")'>0 Q
-        S LINE=""
-        F IND=1:1:DDATA(SUB,"MAX") D
-        . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APP",IND))
-        . F JND=1:1:DDATA(SUB,"LEN") D
-        .. S KND=$P(DDATA(SUB),",",JND)
-        .. S LND=""
-        .. F  S LND=$O(DDATA(SUB,KND,LND)) Q:LND=""  D
-        ... S PIECE=$P(DDATA(SUB,KND,KND),U,2)
-        ... S LINE=LINE_$P(TEMP,U,PIECE)_DC
-        W LINE
-        Q
-        ;
-PDELDATA(DFN,DC,DTYPE,DDATA,SUB)        ;Print the delimited data.
-        N IND,JND,KND,LINE,LND,TEMP,TTEMP
-        S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
-        S LINE=""
-        F IND=1:1:DDATA(DTYPE,"LEN") D
-        . S JND=$P(DDATA(DTYPE),",",IND)
-        . S KND=""
-        . F  S KND=$O(DDATA(DTYPE,JND,KND)) Q:KND=""  D
-        .. S MAX=$P(DDATA(DTYPE,JND,KND),U,3)
-        .. I MAX="" S LINE=LINE_$P(TEMP,U,KND)_DC Q
-        .. I +MAX>1 S TTEMP=$P(TEMP,U,KND) F LND=1:1:MAX S LINE=LINE_$P(TTEMP,"~",LND)_DC
-        W LINE
-        Q
-        ;
-PFACHDR(DDATA,SUB)      ;Build the preferred facility header.
-        I DDATA(SUB,0)=1 S DDATA(SUB,"HDR")="PATIENT'S PREFERRED FACILITY"
-        Q
-        ;
-PFACDATA(DFN,DDATA,SUB) ;Print the patient's preferred facility data, delimited.
-        I DDATA(SUB,0)=0 Q
-        W ^TMP("PXRMPLD",$J,DFN,"PFAC")
-        Q
-        ;
-PFACPR(DFN,DDATA,SUB)   ;Print the patient's preferred facility.
-        I DDATA(SUB,0)=0 Q
-        D ADDTXT("Patient's Preferred Facility")
-        D ADDTXT(" "_$G(^TMP("PXRMPLD",$J,DFN,"PFAC")))
-        Q
-        ;
-PFINDATA(DFN,DC,DDATA,SUB)      ;Print the finding data.
-        N IND,JND,LINE,TEMP
-        I DDATA(SUB,"LEN")'>0 Q
-        S LINE=""
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FIND",JND))
-        . S LINE=LINE_TEMP_DC
-        W LINE
-        Q
-        ;
-PREMDATA(DFN,DC,DDATA,SUB)      ;Print the reminder data.
-        N IND,JND,LINE,TEMP
-        I DDATA(SUB,"LEN")'>0 Q
-        S LINE=""
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . S LINE=LINE_DDATA(SUB,"RNAME",JND)_DC
-        . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REM",DDATA(SUB,"IEN",JND)))
-        . S LINE=LINE_$P(TEMP,U,2)_DC_$P(TEMP,U,3)_"^"_$P(TEMP,U,4)_DC
-        W LINE
-        Q
-        ;
-REGPR(PLIEN,DDATA,SUB)  ;
-        ;Print the regular report..
-        N DATATYPE,DFN,PNAME,LINCNT
-        K ^TMP("PXRMPDEM",$J)
-        S LINCNT=0
-        D TITLE(PLIEN,0)
-        S PNAME=":"
-        F  S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME=""  D
-        . S DFN=0
-        . F  S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN=""  D
-        .. D ADDTXT(" ")
-        .. D ADDTXT("---------- "_PNAME_" DFN="_DFN_" ----------")
-        .. S DATATYPE=""
-        .. F  S DATATYPE=$O(^TMP("PXRMPLD",$J,DFN,DATATYPE)) Q:DATATYPE=""  D
-        ... I DATATYPE="ADD" D VADPTPR(DFN,"Address Data",DATATYPE,.DDATA,"ADD") Q
-        ... I DATATYPE="APP" D APPPRINT(DFN,.DDATA,"APP") Q
-        ... I DATATYPE="DEM" D VADPTPR(DFN,"Demographic Data",DATATYPE,.DDATA,"DEM") Q
-        ... I DATATYPE="ELIG" D VADPTPR(DFN,"Eligibility Data",DATATYPE,.DDATA,"ELIG") Q
-        ... I DATATYPE="FIND" D FINDPR(DFN,.DDATA,"FIND") Q
-        ... I DATATYPE="INP" D VADPTPR(DFN,"Inpatient Data",DATATYPE,.DDATA,"INP") Q
-        ... I DATATYPE="PFAC" D PFACPR(DFN,.DDATA,"PFAC") Q
-        ... I DATATYPE="REM" D REMPR(DFN,.DDATA,"REM") Q
-        D OUTPUT
-        K ^TMP("PXRMPDEM",$J)
-        Q
-        ;
-REMHDR(DC,DDATA,SUB)    ;Build the reminder data delimited header.
-        N HDR,IND,JND
-        S HDR=""
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . S HDR=HDR_"REMINDER"_JND_DC_"STATUS"_JND_DC_"DUE DATE"_JND_DC_"LAST DONE"_JND_DC
-        S DDATA(SUB,"HDR")=HDR
-        Q
-        ;
-REMPR(DFN,DDATA,SUB)    ;Print reminder status information.
-        N DUE,IND,JND,LAST,LINE,NSP,STATUS,TEMP
-        D ADDTXT(" ")
-        S LINE="Reminder:"_$$INSCHR^PXRMEXLC(27," ")_"--STATUS--  --DUE DATE--  --LAST DONE--"
-        D ADDTXT(LINE)
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . S RIEN=DDATA(SUB,"IEN",JND)
-        . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REM",RIEN))
-        . I TEMP="" Q
-        . S STATUS=$P(TEMP,U,2)
-        . S DUE=$P(TEMP,U,3),DUE=$$EDATE^PXRMDATE(DUE)
-        . S LAST=$P(TEMP,U,4),LAST=$$EDATE^PXRMDATE(LAST)
-        . S NSP=38-$L(DDATA(SUB,"RNAME",JND))
-        . S LINE=DDATA(SUB,"RNAME",JND)_$$INSCHR^PXRMEXLC(NSP," ")_STATUS
-        . S NSP=54-$L(LINE)-($L(DUE)/2)
-        . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_DUE
-        . S NSP=69-$L(LINE)-($L(LAST)/2)
-        . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_LAST
-        . D ADDTXT(LINE)
-        Q
-        ;
-TITLE(PLIEN,DELIM)      ;Print the report title.
-        N LISTNAME
-        S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
-        I DELIM D
-        . W @IOF
-        . W !,"Patient Demographic Report"
-        . W !,"   Patient List: "_LISTNAME
-        . W !,"   Created on "_$$FMTE^XLFDT(DCREAT)
-        I 'DELIM D
-        . D ADDTXT("Patient Demographic Report")
-        . D ADDTXT("   Patient List: "_LISTNAME)
-        . D ADDTXT("   Created on "_$$FMTE^XLFDT(DCREAT))
-        Q
-        ;
-VADPTPR(DFN,DNAME,DTYPE,DDATA,SUB)      ;Print data returned by a VADPT call.
-        N IND,JND,KND,LINE,LND,MAX,TEMP,TTEMP
-        D ADDTXT(" ")
-        D ADDTXT(DNAME)
-        S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
-        F IND=1:1:DDATA(SUB,"LEN") D
-        . S JND=$P(DDATA(SUB),",",IND)
-        . S KND=""
-        . F  S KND=$O(DDATA(SUB,JND,KND)) Q:KND=""  D
-        .. S TTEMP=$P(TEMP,U,KND)
-        .. S MAX=+$P(DDATA(SUB,JND,KND),U,3)
-        .. I MAX=0 S MAX=1
-        .. F LND=1:1:MAX D
-        ... S LINE=" "_$P(DDATA(SUB,JND,KND),U,1)_": "_$P(TTEMP,"~",LND)
-        ... D ADDTXT(LINE)
-        Q
-        ;
+PXRMPDRP ;SLC/AGP,PKR - Patient List Demographic report print routine ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ADDTXT(TEXT) ;Accumulate text in ^TMP.
+ S LINCNT=LINCNT+1
+ S ^TMP("PXRMPDEM",$J,LINCNT)=TEXT
+ Q
+ ;
+APPHDR(DC,APPDATA) ;Build the appointment header.
+ I APPDATA("LEN")'>0 Q
+ N HDR,IND,JND,KND,LND,TEMP
+ S IND=0,HDR=""
+ F IND=1:1:APPDATA("MAX") D
+ . F JND=1:1:APPDATA("LEN") D
+ .. S KND=$P(APPDATA,",",JND)
+ .. S LND=""
+ .. F  S LND=$O(APPDATA(KND,LND)) Q:LND=""  D
+ ... S TEMP=$P(APPDATA(KND,LND),U,1)
+ ... S HDR=HDR_TEMP_IND_DC
+ S APPDATA("HDR")=HDR
+ Q
+ ;
+APPPRINT(DFN,APPDATA) ;Print appointment data.
+ N CLINIC,COUNT,DATE,HDR,IND,JND,KND,LINE,PCLINIC,PDATE,TEMP
+ S (PCLINIC,PDATE)=0
+ F IND=1:1:APPDATA("LEN") D
+ . S JND=$P(APPDATA,",",IND)
+ . I JND=1 S PDATE=1
+ . I JND=2 S PCLINIC=1
+ S HDR=""
+ I PDATE S HDR=" "_$P(APPDATA(1,1),U,1)
+ I PCLINIC S HDR=HDR_"   "_$P(APPDATA(2,2),U,1)
+ D ADDTXT(" ")
+ D ADDTXT("Appointment Data")
+ D ADDTXT(HDR)
+ S COUNT=0
+ F  S COUNT=$O(^TMP("PXRMPLD",$J,DFN,"APPDATA",COUNT)) Q:COUNT=""  D
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APPDATA",COUNT))
+ . S LINE=""
+ . I PDATE S LINE=LINE_$P(TEMP,U,1)
+ . I PCLINIC S LINE=LINE_"  "_$P(TEMP,U,2)
+ . D ADDTXT(LINE)
+ Q
+ ;
+DELIMHDR(DC,DATA) ;Build the delimited header for a data type.
+ I DATA("LEN")'>0 Q
+ N HDR,IND,JND,KND,LND,MAX,TEMP
+ S IND=0,HDR=""
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
+ . S KND=""
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
+ .. S TEMP=$P(DATA(JND,KND),U,1)
+ .. S MAX=$P(DATA(JND,KND),U,3)
+ .. I MAX="" S HDR=HDR_TEMP_DC
+ .. I +MAX>0 F LND=1:1:MAX S HDR=HDR_TEMP_LND_DC
+ S DATA("HDR")=HDR
+ Q
+ ;
+DELIMPR(DC,PLIEN,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;
+ ;Print the delimited report.
+ N DATALIST,DFN,IND,NDT,PNAME
+ S NDT=0
+ I ADDDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ADDDATA"
+ I APPDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="APPDATA"
+ I DEMDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="DEMDATA"
+ I ELIGDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ELIGDATA"
+ I FINDDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="FINDDATA"
+ I INPDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="INPDATA"
+ I PFACDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="PFACDATA"
+ I REMDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="REMDATA"
+ D TITLE(PLIEN,1)
+ ;Output the delimited header.
+ F IND=1:1:NDT D
+ . I DATALIST(IND)="ADDDATA" D DELIMHDR(DC,.ADDDATA) Q
+ . I DATALIST(IND)="APPDATA" D APPHDR(DC,.APPDATA) Q
+ . I DATALIST(IND)="DEMDATA" D DELIMHDR(DC,.DEMDATA) Q
+ . I DATALIST(IND)="ELIGDATA" D DELIMHDR(DC,.ELIGDATA) Q
+ . I DATALIST(IND)="FINDDATA" D DELIMHDR(DC,.FINDDATA) Q
+ . I DATALIST(IND)="INPDATA" D DELIMHDR(DC,.INPDATA) Q
+ . I DATALIST(IND)="PFACDATA" D PFACHDR(.PFACDATA)
+ . I DATALIST(IND)="REMDATA" D REMHDR(DC,.REMDATA) Q
+ D DELTITLE(DC,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
+ S PNAME=":"
+ F  S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME=""  D
+ . S DFN=""
+ . F  S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN=""  D
+ .. W !,PNAME_DC
+ .. F IND=1:1:NDT D
+ ... I DATALIST(IND)="ADDDATA" D PDELDATA(DFN,DC,DATALIST(IND),.ADDDATA) Q
+ ... I DATALIST(IND)="APPDATA" D PAPPDATA(DFN,DC,.APPDATA) Q
+ ... I DATALIST(IND)="DEMDATA" D PDELDATA(DFN,DC,DATALIST(IND),.DEMDATA) Q
+ ... I DATALIST(IND)="ELIGDATA" D PDELDATA(DFN,DC,DATALIST(IND),.ELIGDATA) Q
+ ... I DATALIST(IND)="FINDDATA" D PFINDATA(DFN,DC,.FINDDATA) Q
+ ... I DATALIST(IND)="INPDATA" D PDELDATA(DFN,DC,DATALIST(IND),.INPDATA) Q
+ ... I DATALIST(IND)="PFACDATA" D PFACDATA(DFN,.PFACDATA) Q
+ ... I DATALIST(IND)="REMDATA" D PREMDATA(DFN,DC,.REMDATA) Q
+ .. W "\\"
+ Q
+ ;
+DELTITLE(DC,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;Combine
+ ;all the headers to create the delimited title.
+ W !,"PATIENT"_DC
+ W $G(ADDDATA("HDR"))
+ W $G(APPDATA("HDR"))
+ W $G(DEMDATA("HDR"))
+ W $G(ELIGDATA("HDR"))
+ W $G(FINDDATA("HDR"))
+ W $G(INPDATA("HDR"))
+ W $G(PFACDATA("HDR"))
+ W $G(REMDATA("HDR"))
+ W "\\"
+ Q
+ ;
+FINDPR(DFN,FINDDATA) ;Print finding information.
+ N IND,JND,LINE,TEMP
+ D ADDTXT(" ")
+ S LINE="Finding Data"
+ D ADDTXT(LINE)
+ F IND=1:1:FINDDATA("LEN") D
+ . S JND=$P(FINDDATA,",",IND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND))
+ . I TEMP="" Q
+ . S LINE=" "_$P(FINDDATA(JND,JND),U,1)_": "_TEMP
+ . D ADDTXT(LINE)
+ Q
+ ;
+OUTPUT ;Output the text.
+ N IND,LC,LO,VSIZE
+ S VSIZE=IOSL-2
+ S (LC,LO)=0
+ F IND=1:1:LINCNT D
+ . S LC=LC+1,LO=LO+1
+ . W !,^TMP("PXRMPDEM",$J,LC)
+ . I LO=VSIZE D
+ .. D PAGE
+ .. I $D(DTOUT)!$D(DUOUT) S IND=LINCNT Q
+ .. S LO=0
+ Q
+ ;
+PAGE ;
+ I ($E(IOST)="C")&(IO=IO(0)) D
+ . N DIR
+ . S DIR(0)="E"
+ . W !
+ . D ^DIR K DIR
+ I $D(DUOUT)!$D(DTOUT) Q
+ W:$D(IOF) @IOF
+ I $E(IOST)="C",IO=IO(0) W @IOF
+ Q
+ ;
+PAPPDATA(DFN,DC,APPDATA) ;Print the delimited appointment data.
+ N IND,JND,KND,LINE,LND,PIECE,TEMP
+ I APPDATA("LEN")'>0 Q
+ S LINE=""
+ F IND=1:1:APPDATA("MAX") D
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APPDATA",IND))
+ . F JND=1:1:APPDATA("LEN") D
+ .. S KND=$P(APPDATA,",",JND)
+ .. S LND=""
+ .. F  S LND=$O(APPDATA(KND,LND)) Q:LND=""  D
+ ... S PIECE=$P(APPDATA(KND,KND),U,2)
+ ... S LINE=LINE_$P(TEMP,U,PIECE)_DC
+ W LINE
+ Q
+ ;
+PDELDATA(DFN,DC,DTYPE,DATA) ;Print the delimited data.
+ N IND,JND,KND,LINE,LND,TEMP,TTEMP
+ I DATA("LEN")'>0 Q
+ S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
+ S LINE=""
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
+ . S KND=""
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
+ .. S MAX=$P(DATA(JND,KND),U,3)
+ .. I MAX="" S LINE=LINE_$P(TEMP,U,KND)_DC Q
+ .. I +MAX>1 S TTEMP=$P(TEMP,U,KND) F LND=1:1:MAX S LINE=LINE_$P(TTEMP,"~",LND)_DC
+ W LINE
+ Q
+ ;
+PFACHDR(PFACDATA) ;Build the preferred facility header.
+ I PFACDATA(0)=1 S PFACDATA("HDR")="PATIENT'S PREFERRED FACILITY"
+ Q
+ ;
+PFACDATA(DFN,PFACDATA) ;Print the patient's preferred facility data, delimited.
+ I PFACDATA(0)=0 Q
+ W ^TMP("PXRMPLD",$J,DFN,"PFACDATA")
+ Q
+ ;
+PFACPR(DFN,PFACDATA) ;Print the patient's preferred facility.
+ I PFACDATA(0)=0 Q
+ D ADDTXT("Patient's Preferred Facility")
+ D ADDTXT(" "_$G(^TMP("PXRMPLD",$J,DFN,"PFACDATA")))
+ Q
+ ;
+PFINDATA(DFN,DC,FINDDATA) ;Print the finding data.
+ N IND,JND,LINE,TEMP
+ I FINDDATA("LEN")'>0 Q
+ S LINE=""
+ F IND=1:1:FINDDATA("LEN") D
+ . S JND=$P(FINDDATA,",",IND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND))
+ . S LINE=LINE_TEMP_DC
+ W LINE
+ Q
+ ;
+PREMDATA(DFN,DC,REMDATA) ;Print the reminder data.
+ N IND,JND,LINE,TEMP
+ I REMDATA("LEN")'>0 Q
+ S LINE=""
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
+ . S LINE=LINE_REMDATA("RNAME",JND)_DC
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REMDATA",REMDATA("IEN",JND)))
+ . S LINE=LINE_$P(TEMP,U,2)_DC_$P(TEMP,U,3)_"^"_$P(TEMP,U,4)_DC
+ W LINE
+ Q
+ ;
+REGPR(PLIEN,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;
+ ;Print the regular report..
+ N DATATYPE,DFN,PNAME,LINCNT
+ K ^TMP("PXRMPDEM",$J)
+ S LINCNT=0
+ D TITLE(PLIEN,0)
+ S PNAME=":"
+ F  S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME=""  D
+ . S DFN=0
+ . F  S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN=""  D
+ .. D ADDTXT(" ")
+ .. D ADDTXT("---------- "_PNAME_" DFN="_DFN_" ----------")
+ .. S DATATYPE=""
+ .. F  S DATATYPE=$O(^TMP("PXRMPLD",$J,DFN,DATATYPE)) Q:DATATYPE=""  D
+ ... I DATATYPE="ADDDATA" D VADPTPR(DFN,"Address Data",DATATYPE,.ADDDATA) Q
+ ... I DATATYPE="APPDATA" D APPPRINT(DFN,.APPDATA) Q
+ ... I DATATYPE="DEMDATA" D VADPTPR(DFN,"Demographic Data",DATATYPE,.DEMDATA) Q
+ ... I DATATYPE="ELIGDATA" D VADPTPR(DFN,"Eligibility Data",DATATYPE,.ELIGDATA) Q
+ ... I DATATYPE="FINDDATA" D FINDPR(DFN,.FINDDATA) Q
+ ... I DATATYPE="INPDATA" D VADPTPR(DFN,"Inpatient Data",DATATYPE,.INPDATA) Q
+ ... I DATATYPE="PFACDATA" D PFACPR(DFN,.PFACDATA) Q
+ ... I DATATYPE="REMDATA" D REMPR(DFN,.REMDATA) Q
+ D OUTPUT
+ K ^TMP("PXRMPDEM",$J)
+ Q
+ ;
+REMHDR(DC,REMDATA) ;Build the reminder data delimited header.
+ N HDR,IND,JND
+ S HDR=""
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
+ . S HDR=HDR_"REMINDER"_JND_DC_"STATUS"_JND_DC_"DUE DATE"_JND_DC_"LAST DONE"_JND_DC
+ S REMDATA("HDR")=HDR
+ Q
+ ;
+REMPR(DFN,REMDATA) ;Print reminder status information.
+ N DUE,IND,JND,LAST,LINE,NSP,STATUS,TEMP
+ D ADDTXT(" ")
+ S LINE="Reminder:"_$$INSCHR^PXRMEXLC(27," ")_"--STATUS--  --DUE DATE--  --LAST DONE--"
+ D ADDTXT(LINE)
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
+ . S RIEN=REMDATA("IEN",JND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REMDATA",RIEN))
+ . I TEMP="" Q
+ . S STATUS=$P(TEMP,U,2)
+ . S DUE=$P(TEMP,U,3),DUE=$$EDATE^PXRMDATE(DUE)
+ . S LAST=$P(TEMP,U,4),LAST=$$EDATE^PXRMDATE(LAST)
+ . S NSP=38-$L(REMDATA("RNAME",JND))
+ . S LINE=REMDATA("RNAME",JND)_$$INSCHR^PXRMEXLC(NSP," ")_STATUS
+ . S NSP=54-$L(LINE)-($L(DUE)/2)
+ . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_DUE
+ . S NSP=69-$L(LINE)-($L(LAST)/2)
+ . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_LAST
+ . D ADDTXT(LINE)
+ Q
+ ;
+TITLE(PLIEN,DELIM) ;Print the report title.
+ N LISTNAME
+ S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
+ I DELIM D
+ . W @IOF
+ . W !,"Patient Demographic Report"
+ . W !,"   Patient List: "_LISTNAME
+ . W !,"   Created on "_$$FMTE^XLFDT(DCREAT)
+ I 'DELIM D
+ . D ADDTXT("Patient Demographic Report")
+ . D ADDTXT("   Patient List: "_LISTNAME)
+ . D ADDTXT("   Created on "_$$FMTE^XLFDT(DCREAT))
+ Q
+ ;
+VADPTPR(DFN,DNAME,DTYPE,DATA) ;Print data returned by a VADPT call.
+ N IND,JND,KND,LINE,LND,MAX,TEMP,TTEMP
+ D ADDTXT(" ")
+ D ADDTXT(DNAME)
+ S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
+ . S KND=""
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
+ .. S TTEMP=$P(TEMP,U,KND)
+ .. S MAX=+$P(DATA(JND,KND),U,3)
+ .. I MAX=0 S MAX=1
+ .. F LND=1:1:MAX D
+ ... S LINE=" "_$P(DATA(JND,KND),U,1)_": "_$P(TTEMP,"~",LND)
+ ... D ADDTXT(LINE)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m

@@ -1 @@
-PXRMPDRS        ;SLC/PKR - Patient List Demographic Report data selection. ;03/22/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-ADDSEL(DATA,SUB)        ;Let the user select the address information they want.
-        N ADDLIST,LIST
-        S ADDLIST("A",1)=" 1 - CURRENT ADDRESS",DATA(SUB,1,1)="STREET ADDRESS #1"_U_1
-        S DATA(SUB,1,2)="STREET ADDRESS #2"_U_1,DATA(SUB,1,3)="STREET ADDRESS #3"_U_1
-        S DATA(SUB,1,4)="CITY"_U_1,DATA(SUB,1,5)="STATE"_U_2,DATA(SUB,1,6)="ZIP"_U_1
-        S DATA(SUB,1,7)="COUNTY"_U_2
-        S ADDLIST("A",2)=" 2 - PHONE NUMBER",DATA(SUB,2,8)="PHONE NUMBER"_U_1
-        S ADDLIST("A")="Enter your selection(s)"
-        S ADDLIST("?")="^D HELP^PXRMPDRS"
-        W !!,"Select from the following address items:"
-        S LIST=$$SEL^PXRMPDRS(.ADDLIST,2)
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATA(SUB)=LIST
-        S DATA(SUB,"LEN")=$L(LIST,",")-1
-        Q
-        ;
-APPERR  ;
-        N ECODE
-        I $D(ZTQUEUED) D  Q
-        . N NL,TIME
-        . S TIME=$$NOW^XLFDT
-        . S TIME=$$FMTE^XLFDT(TIME)
-        . K ^TMP("PXRMXMZ",$J)
-        . S ^TMP("PXRMXMZ",$J,1,0)="The Patient Demographic Report requested by "_$$GET1^DIQ(200,DBDUZ,.01)_" on "
-        . S ^TMP("PXRMXMZ",$J,2,0)=TIME_" was supposed to include appointment data."
-        . S ^TMP("PXRMXMZ",$J,3,0)="Appointment data could not be obtained from the Scheduling database due to the"
-        . S ^TMP("PXRMXMZ",$J,4,0)="following error(s):"
-        . S ECODE=0,NL=4
-        . F  S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE=""  D
-        .. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDAMA301",ECODE)
-        . D SEND^PXRMMSG("Scheduling database error(s)",1)
-        . S ZTSTOP=1
-        ;
-        I '$D(ZTQUEUED) D  Q
-        . W @IOF
-        . W !,"Appointment data could not be obtained from the Scheduling database due to the"
-        . W !,"following error(s):"
-        . S ECODE=0
-        . F  S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE=""  D
-        .. W !," ",^TMP($J,"SDAMA301",ECODE)
-        Q
-        ;
-APPSEL(DATA,SUB)        ;Let the user select the appointment information they want.
-        ;The first subscript of APPDATA is the selection number and the
-        ;the second subscript is the subscript where the data is returned
-        ;in VAPA. The first piece of APPDATA is the name of the data and the
-        ;second piece is the piece of VAPA this is displayed.
-        N APPLIST,LIST,MAX
-        S APPLIST("A",1)=" 1 - APPOINTMENT DATE",DATA(SUB,1,1)="APPOINTMENT DATE"_U_1
-        S APPLIST("A",2)=" 2 - CLINIC",DATA(SUB,2,2)="CLINIC"_U_2
-        S APPLIST("A")="Enter your selection(s)"
-        S APPLIST("?")="^D HELP^PXRMPDRS"
-        W !!,"Select from the following future appointment items:"
-        S LIST=$$SEL^PXRMPDRS(.APPLIST,2)
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATA(SUB)=LIST
-        S DATA(SUB,"LEN")=$L(LIST,",")-1
-        I DATA(SUB,"LEN")=0 Q
-        S DATA(SUB,"MAX")=$$ASKNUM^PXRMEUT("Maximum number of appointments to display",1,25)
-        Q
-        ;
-DATASEL(LISTIEN,DATA,SUB)       ; Build a list of data that is availble for
-        ;this patient list and let the user select what they want.
-        N IND,DATALIST,DTYPE
-        S DTYPE="",IND=0
-        F  S DTYPE=$O(^PXRMXP(810.5,LISTIEN,35,"B",DTYPE)) Q:DTYPE=""  D
-        . S IND=IND+1,DATALIST("A",IND)=" "_IND_" - "_DTYPE
-        . S DATA(SUB,IND,IND)=DTYPE
-        ;If there is no data quit.
-        I IND=0 S DATA(SUB,"LEN")=0 Q
-        S DATALIST("A")="Enter your selections(s)"
-        S DATALIST("?")="^D HELP^PXRMPDRS"
-        W !!,"Select from the following patient data:"
-        S LIST=$$SEL^PXRMPDRS(.DATALIST,IND)
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATA(SUB)=LIST
-        S DATA(SUB,"LEN")=$L(LIST,",")-1
-        Q
-        ;
-DEMSEL(DATA,SUB)        ;Let the user select the demographic information they want.
-        ;The first subscript of DATA is the selection number and the
-        ;the second subscript is the subscript where the data is returned
-        ;in VADM. The first piece of DEMDATA is the name of the data and the
-        ;second piece is the piece of VADM this is displayed.
-        N DEMLIST,DTOUT,DUOUT,IND,ITEM,JND,KND,LIST,TEMP
-        S DEMLIST("A",1)=" 1 - SSN",DATA(SUB,1,2)="SSN"_U_2
-        S DEMLIST("A",2)=" 2 - DATE OF BIRTH",DATA(SUB,2,3)="DOB"_U_2
-        S DEMLIST("A",3)=" 3 - AGE",DATA(SUB,3,4)="AGE"_U_1
-        S DEMLIST("A",4)=" 4 - SEX",DATA(SUB,4,5)="SEX"_U_2
-        S DEMLIST("A",5)=" 5 - DATE OF DEATH",DATA(SUB,5,6)="DOD"_U_2
-        S DEMLIST("A",6)=" 6 - REMARKS",DATA(SUB,6,7)="REMARKS"_U_1
-        S DEMLIST("A",7)=" 7 - HISTORIC RACE",DATA(SUB,7,8)="HISTORIC RACE"_U_2
-        S DEMLIST("A",8)=" 8 - RELIGION",DATA(SUB,8,9)="RELIGION"_U_2
-        S DEMLIST("A",9)=" 9 - MARITAL STATUS",DATA(SUB,9,10)="MARTIAL STATUS"_U_2
-        S DEMLIST("A",10)="10 - ETHNICITY",DATA(SUB,10,11)="ETHNICITY"_U_2
-        S DEMLIST("A",11)="11 - RACE",DATA(SUB,11,12)="RACE"_U_2
-        S DEMLIST("A")="Enter your selection(s)"
-        S DEMLIST("?")="^D HELP^PXRMPDRS"
-DSEL    W !!,"Select from the following demographic items:"
-        S LIST=$$SEL^PXRMPDRS(.DEMLIST,11)
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATA(SUB)=LIST
-        S DATA(SUB,"LEN")=$L(LIST,",")-1
-        F IND=1:1:DATA(SUB,"LEN") D
-        . S JND=$P(LIST,",",IND)
-        . S KND=$O(DATA(SUB,JND,""))
-        . S TEMP=$P(DATA(SUB,JND,KND),U,1)
-        . I TEMP="SSN" D
-        .. N FULLSSN
-        .. D SSN^PXRMXSD(.FULLSSN)
-        .. S DATA(SUB,"FULLSSN")=$S($G(FULLSSN)="Y":1,1:0)
-        . I $D(DTOUT)!$D(DUOUT) S IND=DATA(SUB,"LEN")+1 Q
-        . I TEMP="ETHNICITY" S $P(DATA(SUB,10,11),U,3)=$$ASKNUM^PXRMEUT("Maximum number of ethnicity entries to display",1,10)
-        . I TEMP="RACE" S $P(DATA(SUB,11,12),U,3)=$$ASKNUM^PXRMEUT("Maximum number of race entries to display",1,10)
-        I $D(DTOUT)!$D(DUOUT) K DTOUT,DUOUT G DSEL
-        Q
-        ;
-ELIGSEL(DATA,SUB)       ;Let the user select the eligibility data they want.
-        ;The first subscript of ELIGDATA is the selection number and the
-        ;the second subscript is the subscript where the data is returned
-        ;in VAEL. The first piece of ELIGDATA is the name of the data and the
-        ;second piece is the piece of VAEL this is displayed.
-        N ELIGLIST,ITEM,LIST
-        S ELIGLIST("A",1)=" 1 - PRIMARY ELGIBILITY CODE",DATA(SUB,1,1)="PRIMARY ELGIBILITY CODE"_U_2
-        S ELIGLIST("A",2)=" 2 - PERIOD OF SERVICE",DATA(SUB,2,2)="PERIOD OF SERVICE"_U_2
-        S ELIGLIST("A",3)=" 3 - % SERVICE CONNECTED",DATA(SUB,3,3)="% SERVICE CONNECTED"_U_2
-        S ELIGLIST("A",4)=" 4 - VETERAN",DATA(SUB,4,4)="VETERAN"_U_1
-        S ELIGLIST("A",5)=" 5 - TYPE",DATA(SUB,5,6)="TYPE"_U_2
-        S ELIGLIST("A",6)=" 6 - ELIGIBILITY STATUS",DATA(SUB,6,8)="ELIGIBILITY STATUS"_U_2
-        S ELIGLIST("A",7)=" 7 - CURRENT MEANS TEST",DATA(SUB,7,9)="CURRENT MEANS TEST"_U_2
-        S ELIGLIST("A")="Enter your selection(s)"
-        S ELIGLIST("?")="^D HELP^PXRMPDRS"
-        W !!,"Select from the following eligibility items:"
-        S LIST=$$SEL^PXRMPDRS(.ELIGLIST,7)
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATA(SUB)=LIST
-        S DATA(SUB,"LEN")=$L(LIST,",")-1
-        Q
-        ;
-HELP    ; -- help code.
-        W !!,"You can choose any combination of numbers i.e., 1-4 or 1,3-5"
-        W !!,"See the Clinical Reminders Managers manual for detailed explanations of each"
-        W !,"of the selection items."
-        Q
-        ;
-INPSEL(DATA,SUB)        ;Let the user select the inpatient information they want.
-        ;The first subscript of INPDATA is the selection number and the
-        ;the second subscript is the subscript where the data is returned
-        ;in VAIN. The first piece of INPDATA is the name of the data and the
-        ;second piece is the piece of VAIN this is displayed.
-        N INPLIST,ITEM,LIST
-        S INPLIST("A",1)=" 1 - WARD LOCATION",DATA(SUB,1,4)="WARD"_U_2
-        S INPLIST("A",2)=" 2 - ROOM-BED",DATA(SUB,2,5)="ROOM-BED"_U_1
-        S INPLIST("A",3)=" 3 - ADMISSION DATE/TIME",DATA(SUB,3,7)="ADMISSION DATE/TIME"_U_2
-        S INPLIST("A",4)=" 4 - ATTENDING PHYSICIAN",DATA(SUB,4,11)="ATTENDING"_U_2
-        S INPLIST("A")="Enter your selection(s)"
-        S INPLIST("?")="^D HELP^PXRMPDRS"
-        W !!,"Select from the following inpatient items:"
-        S LIST=$$SEL^PXRMPDRS(.INPLIST,5)
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATA(SUB)=LIST
-        S DATA(SUB,"LEN")=$L(LIST,",")-1
-        Q
-        ;
-REMSEL(PLIEN,DATA,SUB)  ;If the list was generated from a reminder report
-        ;let the user select the reminder data they want.
-        I '$P(^PXRMXP(810.5,PLIEN,0),U,9) S DATA(SUB,"LEN")=0 Q
-        N IEN,IND,REMLIST,RNAME
-        S (IEN,IND)=0
-        F  S IEN=$O(^PXRMXP(810.5,PLIEN,45,"B",IEN)) Q:IEN=""  D
-        . S RNAME=$P(^PXD(811.9,IEN,0),U,3)
-        . I RNAME="" S RNAME=$P(^PXD(811.9,IEN,0),U,1)
-        . S IND=IND+1
-        . S DATA(SUB,"RNAME",IND)=RNAME
-        . S DATA(SUB,"IEN",IND)=IEN
-        . S REMLIST("A",IND)=" "_IND_" - "_RNAME
-        S REMLIST("A")="Enter your selection(s)"
-        S REMLIST("?")="^D HELP^PXRMPDRS"
-        W !!,"Include due status information for the following reminder(s):"
-        S LIST=$$SEL^PXRMPDRS(.REMLIST,IND)
-        I $D(DTOUT)!$D(DUOUT) Q
-        S DATA(SUB)=LIST
-        S DATA(SUB,"LEN")=$L(LIST,",")-1
-        Q
-        ;
-SEL(SELLIST,LEN)        ;Select global list
-        N DIR,X,Y
-        M DIR=SELLIST
-        S DIR(0)="LO^1:"_LEN
-        D ^DIR
-        Q Y
-        ;
+PXRMPDRS ;SLC/PKR - Patient List Demographic Report data selection. ;07/18/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ADDSEL(ADDDATA) ;Let the user select the address information they want.
+ N ADDLIST,LIST
+ S ADDLIST("A",1)=" 1 - CURRENT ADDRESS",ADDDATA(1,1)="STREET ADDRESS #1"_U_1
+ S ADDDATA(1,2)="STREET ADDRESS #2"_U_1,ADDDATA(1,3)="STREET ADDRESS #3"_U_1
+ S ADDDATA(1,4)="CITY"_U_1,ADDDATA(1,5)="STATE"_U_2,ADDDATA(1,6)="ZIP"_U_1
+ S ADDDATA(1,7)="COUNTY"_U_2
+ S ADDLIST("A",2)=" 2 - PHONE NUMBER",ADDDATA(2,8)="PHONE NUMBER"_U_1
+ S ADDLIST("A")="Enter your selection(s)"
+ S ADDLIST("?")="^D HELP^PXRMPDRS"
+ W !!,"Select from the following address items:"
+ S LIST=$$SEL^PXRMPDRS(.ADDLIST,2)
+ I $D(DTOUT)!$D(DUOUT) Q
+ S ADDDATA=LIST
+ S ADDDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
+APPERR ;
+ N ECODE
+ I $D(ZTQUEUED) D  Q
+ . N NL,TIME
+ . S TIME=$$NOW^XLFDT
+ . S TIME=$$FMTE^XLFDT(TIME)
+ . K ^TMP("PXRMXMZ",$J)
+ . S ^TMP("PXRMXMZ",$J,1,0)="The Patient Demographic Report requested by "_$$GET1^DIQ(200,DBDUZ,.01)_" on "
+ . S ^TMP("PXRMXMZ",$J,2,0)=TIME_" was supposed to include appointment data."
+ . S ^TMP("PXRMXMZ",$J,3,0)="Appointment data could not be obtained from the Scheduling database due to the"
+ . S ^TMP("PXRMXMZ",$J,4,0)="following error(s):"
+ . S ECODE=0,NL=4
+ . F  S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE=""  D
+ .. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDAMA301",ECODE)
+ . D SEND^PXRMMSG("Scheduling database error(s)",1)
+ . S ZTSTOP=1
+ ;
+ I '$D(ZTQUEUED) D  Q
+ . W @IOF
+ . W !,"Appointment data could not be obtained from the Scheduling database due to the"
+ . W !,"following error(s):"
+ . S ECODE=0
+ . F  S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE=""  D
+ .. W !," ",^TMP($J,"SDAMA301",ECODE)
+ Q
+ ;
+APPSEL(APPDATA) ;Let the user select the appointment information they want.
+ ;The first subscript of APPDATA is the selection number and the
+ ;the second subscript is the subscript where the data is returned
+ ;in VAPA. The first piece of APPDATA is the name of the data and the
+ ;second piece is the piece of VAPA this is displayed.
+ N APPLIST,LIST,MAX
+ S APPLIST("A",1)=" 1 - APPOINTMENT DATE",APPDATA(1,1)="APPOINTMENT DATE"_U_1
+ S APPLIST("A",2)=" 2 - CLINIC",APPDATA(2,2)="CLINIC"_U_2
+ S APPLIST("A")="Enter your selection(s)"
+ S APPLIST("?")="^D HELP^PXRMPDRS"
+ W !!,"Select from the following future appointment items:"
+ S LIST=$$SEL^PXRMPDRS(.APPLIST,2)
+ I $D(DTOUT)!$D(DUOUT) Q
+ S APPDATA=LIST
+ S APPDATA("LEN")=$L(LIST,",")-1
+ I APPDATA("LEN")=0 Q
+ S APPDATA("MAX")=$$ASKNUM^PXRMEUT("Maximum number of appointments to display",1,25)
+ Q
+ ;
+DATASEL(LISTIEN,FINDDATA) ; Build a list of data that is availble for
+ ;this patient list and let the user select what they want.
+ N IND,DATALIST,DTYPE
+ S DTYPE="",IND=0
+ F  S DTYPE=$O(^PXRMXP(810.5,LISTIEN,35,"B",DTYPE)) Q:DTYPE=""  D
+ . S IND=IND+1,DATALIST("A",IND)=" "_IND_" - "_DTYPE
+ . S FINDDATA(IND,IND)=DTYPE
+ ;If there is no data quit.
+ I IND=0 S FINDDATA("LEN")=0 Q
+ S DATALIST("A")="Enter your selections(s)"
+ S DATALIST("?")="^D HELP^PXRMPDRS"
+ W !!,"Select from the following patient data:"
+ S LIST=$$SEL^PXRMPDRS(.DATALIST,IND)
+ I $D(DTOUT)!$D(DUOUT) Q
+ S FINDDATA=LIST
+ S FINDDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
+DEMSEL(DEMDATA) ;Let the user select the demographic information they want.
+ ;The first subscript of DEMDATA is the selection number and the
+ ;the second subscript is the subscript where the data is returned
+ ;in VADM. The first piece of DEMDATA is the name of the data and the
+ ;second piece is the piece of VADM this is displayed.
+ N DEMLIST,DTOUT,DUOUT,IND,ITEM,JND,KND,LIST,TEMP
+ S DEMLIST("A",1)=" 1 - SSN",DEMDATA(1,2)="SSN"_U_2
+ S DEMLIST("A",2)=" 2 - DATE OF BIRTH",DEMDATA(2,3)="DOB"_U_2
+ S DEMLIST("A",3)=" 3 - AGE",DEMDATA(3,4)="AGE"_U_1
+ S DEMLIST("A",4)=" 4 - SEX",DEMDATA(4,5)="SEX"_U_2
+ S DEMLIST("A",5)=" 5 - DATE OF DEATH",DEMDATA(5,6)="DOD"_U_2
+ S DEMLIST("A",6)=" 6 - REMARKS",DEMDATA(6,7)="REMARKS"_U_1
+ S DEMLIST("A",7)=" 7 - HISTORIC RACE",DEMDATA(7,8)="HISTORIC RACE"_U_2
+ S DEMLIST("A",8)=" 8 - RELIGION",DEMDATA(8,9)="RELIGION"_U_2
+ S DEMLIST("A",9)=" 9 - MARITAL STATUS",DEMDATA(9,10)="MARTIAL STATUS"_U_2
+ S DEMLIST("A",10)="10 - ETHNICITY",DEMDATA(10,11)="ETHNICITY"_U_2
+ S DEMLIST("A",11)="11 - RACE",DEMDATA(11,12)="RACE"_U_2
+ S DEMLIST("A")="Enter your selection(s)"
+ S DEMLIST("?")="^D HELP^PXRMPDRS"
+DSEL W !!,"Select from the following demographic items:"
+ S LIST=$$SEL^PXRMPDRS(.DEMLIST,11)
+ I $D(DTOUT)!$D(DUOUT) Q
+ S DEMDATA=LIST
+ S DEMDATA("LEN")=$L(LIST,",")-1
+ F IND=1:1:DEMDATA("LEN") D
+ . S JND=$P(LIST,",",IND)
+ . S KND=$O(DEMDATA(JND,""))
+ . S TEMP=$P(DEMDATA(JND,KND),U,1)
+ . I TEMP="SSN" D
+ .. N FULLSSN
+ .. D SSN^PXRMXSD(.FULLSSN)
+ .. S DEMDATA("FULLSSN")=$S($G(FULLSSN)="Y":1,1:0)
+ . I $D(DTOUT)!$D(DUOUT) S IND=DEMDATA("LEN")+1 Q
+ . I TEMP="ETHNICITY" S $P(DEMDATA(10,11),U,3)=$$ASKNUM^PXRMEUT("Maximum number of ethnicity entries to display",1,10)
+ . I TEMP="RACE" S $P(DEMDATA(11,12),U,3)=$$ASKNUM^PXRMEUT("Maximum number of race entries to display",1,10)
+ I $D(DTOUT)!$D(DUOUT) K DTOUT,DUOUT G DSEL
+ Q
+ ;
+ELIGSEL(ELIGDATA) ;Let the user select the eligibility data they want.
+ ;The first subscript of ELIGDATA is the selection number and the
+ ;the second subscript is the subscript where the data is returned
+ ;in VAEL. The first piece of ELIGDATA is the name of the data and the
+ ;second piece is the piece of VAEL this is displayed.
+ N ELIGLIST,ITEM,LIST
+ S ELIGLIST("A",1)=" 1 - PRIMARY ELGIBILITY CODE",ELIGDATA(1,1)="PRIMARY ELGIBILITY CODE"_U_2
+ S ELIGLIST("A",2)=" 2 - PERIOD OF SERVICE",ELIGDATA(2,2)="PERIOD OF SERVICE"_U_2
+ S ELIGLIST("A",3)=" 3 - % SERVICE CONNECTED",ELIGDATA(3,3)="% SERVICE CONNECTED"_U_2
+ S ELIGLIST("A",4)=" 4 - VETERAN",ELIGDATA(4,4)="VETERAN"_U_1
+ S ELIGLIST("A",5)=" 5 - TYPE",ELIGDATA(5,6)="TYPE"_U_2
+ S ELIGLIST("A",6)=" 6 - ELIGIBILITY STATUS",ELIGDATA(6,8)="ELIGIBILITY STATUS"_U_2
+ S ELIGLIST("A",7)=" 7 - CURRENT MEANS TEST",ELIGDATA(7,9)="CURRENT MEANS TEST"_U_2
+ S ELIGLIST("A")="Enter your selection(s)"
+ S ELIGLIST("?")="^D HELP^PXRMPDRS"
+ W !!,"Select from the following eligibility items:"
+ S LIST=$$SEL^PXRMPDRS(.ELIGLIST,7)
+ I $D(DTOUT)!$D(DUOUT) Q
+ S ELIGDATA=LIST
+ S ELIGDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
+HELP ; -- help code.
+ W !!,"You can choose any combination of numbers i.e., 1-4 or 1,3-5"
+ W !!,"See the Clinical Reminders Managers manual for detailed explanations of each"
+ W !,"of the selection items."
+ Q
+ ;
+INPSEL(INPDATA) ;Let the user select the inpatient information they want.
+ ;The first subscript of INPDATA is the selection number and the
+ ;the second subscript is the subscript where the data is returned
+ ;in VAIN. The first piece of INPDATA is the name of the data and the
+ ;second piece is the piece of VAIN this is displayed.
+ N INPLIST,ITEM,LIST
+ S INPLIST("A",1)=" 1 - WARD LOCATION",INPDATA(1,4)="WARD"_U_2
+ S INPLIST("A",2)=" 2 - ROOM-BED",INPDATA(2,5)="ROOM-BED"_U_1
+ S INPLIST("A",3)=" 3 - ADMISSION DATE/TIME",INPDATA(3,7)="ADMISSION DATE/TIME"_U_2
+ S INPLIST("A",4)=" 4 - ATTENDING PHYSICIAN",INPDATA(4,11)="ATTENDING"_U_2
+ S INPLIST("A")="Enter your selection(s)"
+ S INPLIST("?")="^D HELP^PXRMPDRS"
+ W !!,"Select from the following inpatient items:"
+ S LIST=$$SEL^PXRMPDRS(.INPLIST,5)
+ I $D(DTOUT)!$D(DUOUT) Q
+ S INPDATA=LIST
+ S INPDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
+REMSEL(PLIEN,REMDATA) ;If the list was generated from a reminder report
+ ;let the user select the reminder data they want.
+ I '$P(^PXRMXP(810.5,PLIEN,0),U,9) S REMDATA("LEN")=0 Q
+ N IEN,IND,REMLIST,RNAME
+ S (IEN,IND)=0
+ F  S IEN=$O(^PXRMXP(810.5,PLIEN,45,"B",IEN)) Q:IEN=""  D
+ . S RNAME=$P(^PXD(811.9,IEN,0),U,3)
+ . I RNAME="" S RNAME=$P(^PXD(811.9,IEN,0),U,1)
+ . S IND=IND+1
+ . S REMDATA("RNAME",IND)=RNAME
+ . S REMDATA("IEN",IND)=IEN
+ . S REMLIST("A",IND)=" "_IND_" - "_RNAME
+ S REMLIST("A")="Enter your selection(s)"
+ S REMLIST("?")="^D HELP^PXRMPDRS"
+ W !!,"Include due status information for the following reminder(s):"
+ S LIST=$$SEL^PXRMPDRS(.REMLIST,IND)
+ I $D(DTOUT)!$D(DUOUT) Q
+ S REMDATA=LIST
+ S REMDATA("LEN")=$L(LIST,",")-1
+ Q
+ ;
+SEL(SELLIST,LEN) ;Select global list
+ N DIR,X,Y
+ M DIR=SELLIST
+ S DIR(0)="LO^1:"_LEN
+ D ^DIR
+ Q Y
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m

@@ -1 @@
-PXRMPLST        ; SLC/PKR - Build a patient list from a reminder definition. ;01/24/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Input  :  RIEN     - Reminder IEN
-        ;          PLIST    - List returned in ^TMP($J,PLIST,DFN)
-        ;          DFNONLY  - If true list contains only DFN information
-        ;          PXRMDATE - Evaluation date
-        ;===================================================
-BLDPLST(DEFARR,PLIST,DFNONLY)   ;
-        N DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
-        N LIST1,LIST2,LNAME,LSP,LSTACK
-        N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
-        ;
-        ;Get the cohort logic string. This has passed a validation before
-        ;it can be selected for building patient lists so we don't need to
-        ;check it here.
-        S PCLOG=DEFARR(31)
-        I PCLOG="" Q
-        S OPER="!&~"
-        ;Get the sex field, if PCLOG does not contain SEX set it to null.
-        S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"")
-        ;If PCLOG contains age build the corresponding date of birth range(s).
-        I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE)
-        ;Replace &' with ~ so the stack will be built properly.
-        S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~")
-        D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK)
-        ;Process the logic.
-        D CFSAA(.PFSTACK)
-        S (IND,ERROR,LSP,LSTACK(0),NOT)=0
-        F  Q:(IND'<PFSTACK(0))!(ERROR)  D
-        . S IND=IND+1,ELE=PFSTACK(IND)
-        . I ELE["'" S NOT=1
-        . S TYPE=$S(ELE="'":"NOT",ELE["AGE":"A",ELE["FI":"FI",ELE["FF":"FF",ELE="SAA":"SAA",ELE["SEX":"S",OPER[ELE:"OP",1:"")
-        .;
-        . I TYPE="A" D  Q
-        .. S LNAME="LIST"_IND
-        .. D LSA("",NDR,.DOBS,.DOBE,LNAME)
-        .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
-        .. D AGEFI(.DEFARR,LNAME,SEX,"")
-        .;
-        . I TYPE="FI" D  Q
-        .. S IND=IND+1,FNUM=PFSTACK(IND)
-        .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a finding not followed by a number" Q
-        .. S LNAME="LIST"_IND
-        .. D EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME)
-        .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
-        .;
-        . I TYPE="FF" D  Q
-        .. S IND=IND+1,FNUM=PFSTACK(IND)
-        .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a function finding not followed by a number"
-        .. S LNAME="LIST"_IND
-        .. D EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME)
-        .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
-        .;
-        . I TYPE="NOT" S NOT=1 Q 
-        .;
-        . I TYPE="OP" D  Q
-        .. S LIST2=$$POP^PXRMSTAC(.LSTACK)
-        .. S LIST1=$$POP^PXRMSTAC(.LSTACK)
-        .. I NOT S ELE=ELE_"'",NOT=0
-        .. D LOGOP(LIST1,LIST2,ELE)
-        .. D PUSH^PXRMSTAC(.LSTACK,LIST1)
-        .. K ^TMP($J,LIST2)
-        .;
-        . I TYPE="S" D  Q
-        .. S LNAME="LIST"_IND
-        .. D LSEX(SEX,LNAME,.LSTACK)
-        .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
-        .;
-        . I TYPE="SAA" D  Q
-        .. S LNAME="LIST"_IND
-        .. D LSA(SEX,NDR,.DOBS,.DOBE,LNAME)
-        .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
-        .. D AGEFI(.DEFARR,LNAME,SEX,"")
-        .;
-        S LIST1=$$POP^PXRMSTAC(.LSTACK)
-        ;If AGE is not in the cohort logic look for any findings that set the
-        ;frequency to 0Y and therefore remove the patient from the cohort.
-        I PCLOG'["AGE" D AGEFI(.DEFARR,LIST1,"","0Y")
-        ;
-        I $G(DFNONLY) D
-        . S DFN=0
-        . F  S DFN=$O(^TMP($J,LIST1,1,DFN)) Q:DFN=""  D
-        .. S ^TMP($J,PLIST,DFN)=""
-        E  M ^TMP($J,PLIST)=^TMP($J,LIST1)
-        K ^TMP($J,LIST1)
-        Q
-        ;
-        ;==================================================
-AGEFI(DEFARR,LNAME,SEX,ONLYFREQ)        ;Check for patients that need to be
-        ;added or removed because of a finding that changes the age range.
-        N DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP
-        N MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST
-        S NUMAFI=$P(DEFARR(40),U,1)
-        I NUMAFI=0 Q
-        S FILIST=$P(DEFARR(40),U,2)
-        F IND=1:1:NUMAFI D
-        . S FINUM=$P(FILIST,";",IND)
-        . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
-        . S RANK=+$P(TEMP,U,5)
-        . I RANK=0 S RANK=9999
-        . S FREQ=$$FRQINDAY^PXRMDATE($P(TEMP,U,4))
-        .;If there is no frequency with this rank ignore it.
-        . I FREQ]"" S RANKARR(RANK,FREQ,FINUM)=""
-        S IND=0,RANK=""
-        F  S RANK=$O(RANKARR(RANK)) Q:RANK=""  D
-        . S FREQ=""
-        . F  S FREQ=$O(RANKARR(RANK,FREQ)) Q:FREQ=""  D
-        .. S FINUM=0
-        .. F  S FINUM=$O(RANKARR(RANK,FREQ,FINUM)) Q:FINUM=""  D
-        ... S IND=IND+1,RF(IND)=FINUM
-        I IND'=NUMAFI W !,"Error in AGEFI^PXRMPLST - Ranking failed!"
-        ;Build a list for each age finding.
-        F IND=1:1:NUMAFI D
-        . S FINUM=RF(IND)
-        . S TGLIST="AGEFI"_FINUM
-        . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
-        . S FREQ=$P(TEMP,U,4)
-        . I ONLYFREQ="0Y",FREQ'="0Y" S LOGOP(IND)="~" Q
-        . S LOGOP(IND)=$S(FREQ="0Y":"~",FREQ="":"~",1:"!")
-        . S MINAGE=$P(TEMP,U,2)
-        . S MAXAGE=$P(TEMP,U,3)
-        . S DOBE=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
-        . S DOBS=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
-        . K ^TMP($J,TGLIST)
-        . I FINUM=+FINUM D EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST)
-        . I FINUM["FF" D EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST)
-        .;Filter TGLIST based on the age range.
-        . S DFN=$S(FREQ="0Y":$O(^TMP($J,TGLIST,1,""),-1),1:0)
-        . F  S DFN=$O(^TMP($J,TGLIST,1,DFN)) Q:DFN=""  D
-        .. S DEL=0
-        ..;Reference to ^DPT DBIA #10035
-        .. S PSEX=$P(^DPT(DFN,0),U,2),DOB=$P(^DPT(DFN,0),U,3)
-        .. I SEX'="",PSEX'=SEX S DEL=1
-        .. I (DOB<DOBS)!(DOB>DOBE) S DEL=1
-        .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN)
-        ;Remove patients on a list with a higher rank from all lists with
-        ;a lower rank.
-        F IND=1:1:NUMAFI D
-        . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~")
-        F IND=1:1:NUMAFI D
-        . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND))
-        . K ^TMP($J,"AGEFI"_RF(IND))
-        Q
-        ;
-        ;==================================================
-CFSAA(STACK)    ;Check for the first three elements on the stack being
-        ;SEX, AGE, and &. If that is the case replace the with the "special"
-        ;finding SAA.
-        N EL1,EL2,EL3,SAA
-        S SAA=0
-        S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3))
-        I EL1="SEX",EL2="AGE",EL3="&" S SAA=1
-        I EL1="AGE",EL2="SEX",EL3="&" S SAA=1
-        I 'SAA Q
-        ;Create a new pseudo-element for SEX&AGE.
-        S EL1=$$POP^PXRMSTAC(.STACK)
-        S EL1=$$POP^PXRMSTAC(.STACK)
-        S EL1=$$POP^PXRMSTAC(.STACK)
-        D PUSH^PXRMSTAC(.STACK,"SAA")
-        Q
-        ;
-        ;==================================================
-DOBR(DEFARR,NDR,DOBS,DOBE)      ;Build the date of birth range.
-        N IND,FREQ,MINAGE,MAXAGE,TEMP
-        S (IND,NDR)=0
-        F  S IND=+$O(DEFARR(7,IND)) Q:IND=0  D
-        . S TEMP=DEFARR(7,IND,0)
-        . S FREQ=$P(TEMP,U,1)
-        . I (FREQ="0Y")!(FREQ="") Q
-        . S MINAGE=$P(TEMP,U,2)
-        . S MAXAGE=$P(TEMP,U,3)
-        . S NDR=NDR+1
-        . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
-        . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
-        Q
-        ;
-        ;==================================================
-GENTERM(FINDING,FINUM,TERMARR)  ;Given a reminder finding generate a term
-        ;for patient list evaluation.
-        N IEN,IND,TEMP,TYPE
-        S TEMP=$P(FINDING,U,1)
-        S IEN=$P(TEMP,";",1)
-        S TYPE=$P(TEMP,";",2)
-        ;If the finding is a term just load the term.
-        I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q
-        S TERMARR(0)="GENERATED"
-        S TERMARR("IEN")=0
-        M TERMARR(20,1)=DEFARR(20,FINUM)
-        S TERMARR("E",TYPE,IEN,1)=""
-        Q
-        ;
-        ;==================================================
-GETDOB(AGE,TYPE)        ;Given an age in years return the corresponding date of
-        ;birth. If TYPE is MIN then find the date of birth that will make them
-        ;that age. If TYPE is MAX find the last day that will make them
-        ;that age, i.e., the next day is their birthday.
-        N DATE,DOB
-        S DATE=$$NOW^PXRMDATE
-        I TYPE="MIN" S DOB=DATE-(10000*AGE)
-        I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1)
-        Q DOB
-        ;
-        ;==================================================
-LOGOP(LIST1,LIST2,LOGOP)        ;Given LIST1 and LIST2 apply the logical
-        ;operator LOGOP to generate a new list and return it in LIST1
-        N DFN1,DFN2
-        I LOGOP="&" D  Q
-        . S DFN1=""
-        . F  S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1=""  D
-        .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q
-        .. K ^TMP($J,LIST1,1,DFN1)
-        ;
-        ;"~" represents "&'".
-        I LOGOP="~" D  Q
-        . S DFN1=""
-        . F  S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1=""  D
-        .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1)
-        ;
-        I LOGOP="!" D
-        . S DFN2=""
-        . F  S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2=""  D
-        .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2)
-        Q
-        ;
-        ;==================================================
-LSA(SEX,NDR,DOBS,DOBE,LNAME)    ;Build a list from a SEX & AGE finding.
-        ;Reference to ^DPT DBIA #10035
-        N DFN,DS,IND,SEXOK
-        F IND=1:1:NDR D
-        . S DS=DOBS(IND)-.000001
-        . F  S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="")  D
-        .. S DFN=""
-        .. F  S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN=""  D
-        ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0)
-        ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")=""
-        Q
-        ;
-        ;==================================================
-LSEX(SEX,LNAME,LSTACK)  ;Build a list from a SEX finding.
-        ;Reference to ^DPT DBIA #10035
-        N ELIST
-        ;Start with the existing list to build a list based on sex.
-        S ELIST=$$POP^PXRMSTAC(.LSTACK)
-        D PUSH^PXRMSTAC(.LSTACK,ELIST)
-        S DFN=0
-        F  S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN=""  D
-        . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)=""
-        Q
-        ;
+PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;06/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Input  :  RIEN     - Reminder IEN
+ ;          PLIST    - List returned in ^TMP($J,PLIST,DFN)
+ ;          DFNONLY  - If true list contains only DFN information
+ ;          PXRMDATE - Evaluation date
+ ;===================================================
+BLDPLST(RIEN,PLIST,DFNONLY,PXRMDATE) ;
+ N DEFARR,DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
+ N LIST1,LIST2,LNAME,LSP,LSTACK
+ N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
+ ;
+ D DEF^PXRMLDR(RIEN,.DEFARR)
+ ;Get the cohort logic string. This has passed a validation before
+ ;it can be selected for building patient lists so we don't need to
+ ;check it here.
+ S PCLOG=DEFARR(31)
+ I PCLOG="" Q
+ S OPER="!&~"
+ ;Get the sex field, if PCLOG does not contain SEX set it to null.
+ S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"")
+ ;If PCLOG contains age build the corresponding date of birth range(s).
+ I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE)
+ ;Replace &' with ~ so the stack will be built properly.
+ S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~")
+ D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK)
+ ;Process the logic.
+ D CFSAA(.PFSTACK)
+ S (IND,ERROR,LSP,LSTACK(0),NOT)=0
+ F  Q:(IND'<PFSTACK(0))!(ERROR)  D
+ . S IND=IND+1,ELE=PFSTACK(IND)
+ . I ELE["'" S NOT=1
+ . S TYPE=$S(ELE="'":"NOT",ELE["AGE":"A",ELE["FI":"FI",ELE["FF":"FF",ELE="SAA":"SAA",ELE["SEX":"S",OPER[ELE:"OP",1:"")
+ .;
+ . I TYPE="A" D  Q
+ .. S LNAME="LIST"_IND
+ .. D LSA("",NDR,.DOBS,.DOBE,LNAME)
+ .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
+ .. D AGEFI(.DEFARR,LNAME,SEX,"")
+ .;
+ . I TYPE="FI" D  Q
+ .. S IND=IND+1,FNUM=PFSTACK(IND)
+ .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a finding not followed by a number" Q
+ .. S LNAME="LIST"_IND
+ .. D EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME)
+ .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
+ .;
+ . I TYPE="FF" D  Q
+ .. S IND=IND+1,FNUM=PFSTACK(IND)
+ .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a function finding not followed by a number"
+ .. S LNAME="LIST"_IND
+ .. D EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME)
+ .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
+ .;
+ . I TYPE="NOT" S NOT=1 Q 
+ .;
+ . I TYPE="OP" D  Q
+ .. S LIST2=$$POP^PXRMSTAC(.LSTACK)
+ .. S LIST1=$$POP^PXRMSTAC(.LSTACK)
+ .. I NOT S ELE=ELE_"'",NOT=0
+ .. D LOGOP(LIST1,LIST2,ELE)
+ .. D PUSH^PXRMSTAC(.LSTACK,LIST1)
+ .. K ^TMP($J,LIST2)
+ .;
+ . I TYPE="S" D  Q
+ .. S LNAME="LIST"_IND
+ .. D LSEX(SEX,LNAME,.LSTACK)
+ .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
+ .;
+ . I TYPE="SAA" D  Q
+ .. S LNAME="LIST"_IND
+ .. D LSA(SEX,NDR,.DOBS,.DOBE,LNAME)
+ .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
+ .. D AGEFI(.DEFARR,LNAME,SEX,"")
+ .;
+ S LIST1=$$POP^PXRMSTAC(.LSTACK)
+ ;If AGE is not in the cohort logic look for any findings that set the
+ ;frequency to 0Y and therefore remove the patient from the cohort.
+ I PCLOG'["AGE" D AGEFI(.DEFARR,LIST1,"","0Y")
+ ;
+ I $G(DFNONLY) D
+ . S DFN=0
+ . F  S DFN=$O(^TMP($J,LIST1,1,DFN)) Q:DFN=""  D
+ .. S ^TMP($J,PLIST,DFN)=""
+ E  M ^TMP($J,PLIST)=^TMP($J,LIST1)
+ K ^TMP($J,LIST1)
+ Q
+ ;
+ ;==================================================
+AGEFI(DEFARR,LNAME,SEX,ONLYFREQ) ;Check for patients that need to be
+ ;added or removed because of a finding that changes the age range.
+ N DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP
+ N MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST
+ S NUMAFI=$P(DEFARR(40),U,1)
+ I NUMAFI=0 Q
+ S FILIST=$P(DEFARR(40),U,2)
+ F IND=1:1:NUMAFI D
+ . S FINUM=$P(FILIST,";",IND)
+ . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
+ . S RANK=+$P(TEMP,U,5)
+ . I RANK=0 S RANK=9999
+ . S FREQ=$$FRQINDAY^PXRMDATE($P(TEMP,U,4))
+ .;If there is no frequency with this rank ignore it.
+ . I FREQ]"" S RANKARR(RANK,FREQ,FINUM)=""
+ S IND=0,RANK=""
+ F  S RANK=$O(RANKARR(RANK)) Q:RANK=""  D
+ . S FREQ=""
+ . F  S FREQ=$O(RANKARR(RANK,FREQ)) Q:FREQ=""  D
+ .. S FINUM=0
+ .. F  S FINUM=$O(RANKARR(RANK,FREQ,FINUM)) Q:FINUM=""  D
+ ... S IND=IND+1,RF(IND)=FINUM
+ I IND'=NUMAFI W !,"Error in AGEFI^PXRMPLST - Ranking failed!"
+ ;Build a list for each age finding.
+ F IND=1:1:NUMAFI D
+ . S FINUM=RF(IND)
+ . S TGLIST="AGEFI"_FINUM
+ . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
+ . S FREQ=$P(TEMP,U,4)
+ . I ONLYFREQ="0Y",FREQ'="0Y" S LOGOP(IND)="~" Q
+ . S LOGOP(IND)=$S(FREQ="0Y":"~",FREQ="":"~",1:"!")
+ . S MINAGE=$P(TEMP,U,2)
+ . S MAXAGE=$P(TEMP,U,3)
+ . S DOBE=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
+ . S DOBS=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
+ . K ^TMP($J,TGLIST)
+ . I FINUM=+FINUM D EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST)
+ . I FINUM["FF" D EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST)
+ .;Filter TGLIST based on the age range.
+ . S DFN=$S(FREQ="0Y":$O(^TMP($J,TGLIST,1,""),-1),1:0)
+ . F  S DFN=$O(^TMP($J,TGLIST,1,DFN)) Q:DFN=""  D
+ .. S DEL=0
+ ..;Reference to ^DPT DBIA #10035
+ .. S PSEX=$P(^DPT(DFN,0),U,2),DOB=$P(^DPT(DFN,0),U,3)
+ .. I SEX'="",PSEX'=SEX S DEL=1
+ .. I (DOB<DOBS)!(DOB>DOBE) S DEL=1
+ .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN)
+ ;Remove patients on a list with a higher rank from all lists with
+ ;a lower rank.
+ F IND=1:1:NUMAFI D
+ . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~")
+ F IND=1:1:NUMAFI D
+ . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND))
+ . K ^TMP($J,"AGEFI"_RF(IND))
+ Q
+ ;
+ ;==================================================
+CFSAA(STACK) ;Check for the first three elements on the stack being
+ ;SEX, AGE, and &. If that is the case replace the with the "special"
+ ;finding SAA.
+ N EL1,EL2,EL3,SAA
+ S SAA=0
+ S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3))
+ I EL1="SEX",EL2="AGE",EL3="&" S SAA=1
+ I EL1="AGE",EL2="SEX",EL3="&" S SAA=1
+ I 'SAA Q
+ ;Create a new pseudo-element for SEX&AGE.
+ S EL1=$$POP^PXRMSTAC(.STACK)
+ S EL1=$$POP^PXRMSTAC(.STACK)
+ S EL1=$$POP^PXRMSTAC(.STACK)
+ D PUSH^PXRMSTAC(.STACK,"SAA")
+ Q
+ ;
+ ;==================================================
+DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range.
+ N IND,FREQ,MINAGE,MAXAGE,TEMP
+ S (IND,NDR)=0
+ F  S IND=+$O(DEFARR(7,IND)) Q:IND=0  D
+ . S TEMP=DEFARR(7,IND,0)
+ . S FREQ=$P(TEMP,U,1)
+ . I (FREQ="0Y")!(FREQ="") Q
+ . S MINAGE=$P(TEMP,U,2)
+ . S MAXAGE=$P(TEMP,U,3)
+ . S NDR=NDR+1
+ . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
+ . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
+ Q
+ ;
+ ;==================================================
+GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term
+ ;for patient list evaluation.
+ N IEN,IND,TEMP,TYPE
+ S TEMP=$P(FINDING,U,1)
+ S IEN=$P(TEMP,";",1)
+ S TYPE=$P(TEMP,";",2)
+ ;If the finding is a term just load the term.
+ I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q
+ S TERMARR(0)="GENERATED"
+ S TERMARR("IEN")=0
+ M TERMARR(20,1)=DEFARR(20,FINUM)
+ S TERMARR("E",TYPE,IEN,1)=""
+ Q
+ ;
+ ;==================================================
+GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of
+ ;birth. If TYPE is MIN then find the date of birth that will make them
+ ;that age. If TYPE is MAX find the last day that will make them
+ ;that age, i.e., the next day is their birthday.
+ N DATE,DOB
+ S DATE=$$NOW^PXRMDATE
+ I TYPE="MIN" S DOB=DATE-(10000*AGE)
+ I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1)
+ Q DOB
+ ;
+ ;==================================================
+LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
+ ;operator LOGOP to generate a new list and return it in LIST1
+ N DFN1,DFN2
+ I LOGOP="&" D  Q
+ . S DFN1=""
+ . F  S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1=""  D
+ .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q
+ .. K ^TMP($J,LIST1,1,DFN1)
+ ;
+ ;"~" represents "&'".
+ I LOGOP="~" D  Q
+ . S DFN1=""
+ . F  S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1=""  D
+ .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1)
+ ;
+ I LOGOP="!" D
+ . S DFN2=""
+ . F  S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2=""  D
+ .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2)
+ Q
+ ;
+ ;==================================================
+LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding.
+ ;Reference to ^DPT DBIA #10035
+ N DFN,DS,IND,SEXOK
+ F IND=1:1:NDR D
+ . S DS=DOBS(IND)-.1
+ . F  S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="")  D
+ .. S DFN=""
+ .. F  S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN=""  D
+ ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0)
+ ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")=""
+ Q
+ ;
+ ;==================================================
+LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding.
+ ;Reference to ^DPT DBIA #10035
+ N ELIST
+ ;Start with the existing list to build a list based on sex.
+ S ELIST=$$POP^PXRMSTAC(.LSTACK)
+ D PUSH^PXRMSTAC(.LSTACK,ELIST)
+ S DFN=0
+ F  S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN=""  D
+ . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m

@@ -1 @@
-PXRMPTD2        ; SLC/PKR/PJH - Reminder Inquiry print template routines.;03/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;================================================
-DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG)      ;Standard DATE
-        N DATE,X
-        S DATE=$P($G(FIND0),U,PIECE)
-        I DATE'="" D
-        .S DATE=$$FMTE^XLFDT(DATE,"5Z"),X=$$RJ^XLFSTR(TITLE,RJC,PAD),X=X_" "_DATE
-        .D ^DIWP
-        Q
-        ;
-        ;================================================
-ENTRYNAM(VPTR)  ;Given the variable pointer return the entry name. The
-        ;variable pointer list contains the information necessary to do the
-        ;look up.
-        N IEN,FILENUM,NAME,ROOT
-        I VPTR="" Q ""
-        S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2),FILENUM=$P(PXRMFVPL(ROOT),U,1)
-        S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","")
-        Q NAME
-        ;
-        ;================================================
-FREQ(FREQ)      ;Format frequency.
-        I FREQ=-1 Q "Cannot be determined"
-        I +FREQ=0 Q FREQ_" - Not indicated"
-        I FREQ="99Y" Q "99Y - Once"
-        Q +FREQ_($S(FREQ?1N.N1"D":" day",FREQ?1N.N1"M":" month",FREQ?1N.N1"Y":" year",1:""))_$S(+FREQ>1:"s",1:"")
-        ;
-        ;================================================
-FTYPE(VPTR,CNT) ;Return finding type.
-        N FTYPE,ROOT
-        I VPTR="" Q "UNDEFINED?"
-        S ROOT=$P(VPTR,";",2)
-        I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
-        S FTYPE=$S(CNT=1:$P(PXRMFVPL(ROOT),U,4),1:$P(PXRMFVPL(ROOT),U,2))
-        Q FTYPE
-        ;
-        ;================================================
-GENFREQ(PXF0)   ;Print age range frequency set for findings.
-        N PXF,PXW,PXAMIN,PXAMAX
-        S PXF=$P(PXF0,U,4)
-        I PXF="" Q ""
-        S PXAMIN=$P(PXF0,U,2),PXAMAX=$P(PXF0,U,3)
-        S PXW=$$FREQ(PXF)
-        S PXW=PXW_$$FMTAGE^PXRMAGE(PXAMIN,PXAMAX)
-        Q PXW
-        ;
-        ;================================================
-GENIEN(FINDING) ;Return internal entry number for findings.
-        N F0,IEN,PREFIX,ROOT,VPTR
-        S ROOT="^PXD(811.9,D0,20,FINDING,0)"
-        S F0=@ROOT
-        S VPTR=$P(F0,U,1)
-        I VPTR="" Q "UNDEFINED"
-        S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2)
-        I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
-        S VPTR=PXRMFVPL(ROOT)
-        S PREFIX=$P(VPTR,U,4)
-        Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))"
-        ;
+PXRMPTD2 ; SLC/PKR/PJH - Reminder Inquiry print template routines.;10/07/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;================================================
+DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard DATE
+ N DATE,X
+ S DATE=$P($G(FIND0),U,PIECE)
+ I DATE'="" D
+ .S DATE=$$FMTE^XLFDT(DATE,"D"),X=$$RJ^XLFSTR(TITLE,RJC,PAD),X=X_" "_DATE
+ .D ^DIWP
+ Q
+ ;
+ ;================================================
+ENTRYNAM(VPTR) ;Given the variable pointer return the entry name. The
+ ;variable pointer list contains the information necessary to do the
+ ;look up.
+ N IEN,FILENUM,NAME,ROOT
+ I VPTR="" Q ""
+ S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2),FILENUM=$P(PXRMFVPL(ROOT),U,1)
+ S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","")
+ Q NAME
+ ;
+ ;================================================
+FREQ(FREQ) ;Format frequency.
+ I FREQ=-1 Q "Cannot be determined"
+ I +FREQ=0 Q FREQ_" - Not indicated"
+ I FREQ="99Y" Q "99Y - Once"
+ Q +FREQ_($S(FREQ?1N.N1"D":" day",FREQ?1N.N1"M":" month",FREQ?1N.N1"Y":" year",1:""))_$S(+FREQ>1:"s",1:"")
+ ;
+ ;================================================
+FTYPE(VPTR,CNT) ;Return finding type.
+ N FTYPE,ROOT
+ I VPTR="" Q "UNDEFINED?"
+ S ROOT=$P(VPTR,";",2)
+ I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
+ S FTYPE=$S(CNT=1:$P(PXRMFVPL(ROOT),U,4),1:$P(PXRMFVPL(ROOT),U,2))
+ Q FTYPE
+ ;
+ ;================================================
+GENFREQ(PXF0) ;Print age range frequency set for findings.
+ N PXF,PXW,PXAMIN,PXAMAX
+ S PXF=$P(PXF0,U,4)
+ I PXF="" Q ""
+ S PXAMIN=$P(PXF0,U,2),PXAMAX=$P(PXF0,U,3)
+ S PXW=$$FREQ(PXF)
+ S PXW=PXW_$$FMTAGE^PXRMAGE(PXAMIN,PXAMAX)
+ Q PXW
+ ;
+ ;================================================
+GENIEN(FINDING) ;Return internal entry number for findings.
+ N F0,IEN,PREFIX,ROOT,VPTR
+ S ROOT="^PXD(811.9,D0,20,FINDING,0)"
+ S F0=@ROOT
+ S VPTR=$P(F0,U,1)
+ I VPTR="" Q "UNDEFINED"
+ S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2)
+ I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
+ S VPTR=PXRMFVPL(ROOT)
+ S PREFIX=$P(VPTR,U,4)
+ Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))"
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m

@@ -1 @@
-PXRMPTDF        ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;06/07/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;================================================
-PFIND   ;Print the reminder definition finding multiple.
-        N DIWF,FIELD,FILENUM,FINDING,FIND0,FIND3,FINDNAM,FL,HFCAT,HFIEN
-        N IEN1,IND,INT,LEN,PAD,PADS,PARRAY,RJC,RFIND,RTERM,SCNT,SIEN,STAT0
-        ;If called by a FileMan print build the variable pointer list.
-        I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
-        ;No printing is done by PFIND it accumulates all output using ^DIWP.
-        ;The print template outputs the text with ^DIWW.
-        ;Because of the way DIWP works we need to format all the found and
-        ;not found text first and store it in ^TMP.
-        K ^TMP($J,"W")
-        S FILENUM="811.902"
-        S RJC=30,PAD=" ",PADS=""
-        F IND=1:1:(RJC+2) S PADS=PADS_PAD
-        S FINDING=0
-        F  S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0  D
-        .D WPFORMAT(FINDING,20,RJC,1)
-        .D WPFORMAT(FINDING,20,RJC,2)
-        K ^UTILITY($J,"W")
-        S FINDING=0
-        F  S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0  D
-        .D WPFORMAT(FINDING,25,RJC,1)
-        .D WPFORMAT(FINDING,25,RJC,2)
-        S DIWF="C80",DIWL=2
-        K ^UTILITY($J,"W")
-        S FINDING=0
-        F  S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0  D
-        .S FIND0=^PXD(811.9,D0,20,FINDING,0)
-        .S FIELD=$P(FIND0,U,1)
-        .S RTERM=FIELD
-        .S X=" "
-        .D ^DIWP
-        .S FINDNAM=$$ENTRYNAM^PXRMPTD2(FIELD)
-        .I FINDNAM="" S FINDNAM="?"
-        .S X=$$RJ^XLFSTR("---- Begin:",12,PAD)
-        .S X=X_" "_FINDNAM
-        .S RFIND=$$GENIEN^PXRMPTD2(FINDING)
-        .S X=X_" "_RFIND_" "
-        .S LEN=(75-$L(X))
-        .F INT=1:1:LEN S X=X_"-"
-        .D ^DIWP
-        .;
-        .S X=$$RJ^XLFSTR("Finding Type:",RJC,PAD)
-        .S X=X_" "_$$FTYPE^PXRMPTD2(FIELD,0)
-        .D ^DIWP
-        .I RFIND["HF" D
-        ..S HFIEN=$P($P($P(RFIND,"HF",2),"(",2),")")
-        ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3)
-        ..S HFCAT=$S(HFCAT="":"UNDEFINED",1:$P($G(^AUTTHF(HFCAT,0)),U,1))
-        ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD)
-        ..S X=X_" "_HFCAT
-        ..D ^DIWP
-        .;
-        .S FIELD=$P(FIND0,U,4)
-        .I $L(FIELD)>0 D
-        ..S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD)
-        ..S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0)
-        ..D ^DIWP
-        .;
-        .D SFDISP(FIND0,5,6,"Rank Frequency:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,6,7,"Use in Resolution Logic:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,7,8,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM)
-        .D DATE^PXRMPTD2(FIND0,8,9,"Beginning Date/Time:",RJC,PAD,FILENUM)
-        .D DATE^PXRMPTD2(FIND0,11,12,"Ending Date/Time:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD,FILENUM)
-        .I $D(^PXD(811.9,D0,20,FINDING,5,0))=1 D
-        ..S (SCNT,SIEN)=0
-        ..F  S SIEN=$O(^PXD(811.9,D0,20,FINDING,5,SIEN)) Q:SIEN=""  D
-        ...S STAT0=$G(^PXD(811.9,D0,20,FINDING,5,SIEN,0))
-        ...D STATUS(STAT0,"Status List:",RJC) S SCNT=SCNT+1
-        .S FIND0=$G(^PXD(811.9,D0,20,FINDING,3))
-        .D SFDISP(FIND0,1,14,"Condition:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD,FILENUM)
-        .D SFDISP(FIND0,3,18,"Use Status/Cond in Search:",RJC,PAD,FILENUM)
-        .I $G(^PXD(811.9,D0,20,FINDING,15))'="" D 
-        ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
-        ..S X=X_" "_$G(^PXD(811.9,D0,20,FINDING,15))
-        ..D ^DIWP
-        .D WPOUT(FINDING,20,"Found Text:",RJC,PAD,PADS,1)
-        .D WPOUT(FINDING,20,"Not Found Text:",RJC,PAD,PADS,2)
-        .I RTERM["PXRMD(811.5" S IEN1=$P(RTERM,";") D RTERM
-        .S X=$$RJ^XLFSTR("---- End:",10,PADS)
-        .S X=X_" "_FINDNAM_" "
-        .S LEN=(75-$L(X))
-        .F INT=1:1:(LEN) S X=X_"-"
-        .D ^DIWP
-        .S X=" "
-        .D ^DIWP
-        ;
-        ;Function Findings
-        I +$P($G(^PXD(811.9,D0,25,0)),U,4)>0 D
-        .S X=" "
-        .D ^DIWP
-        .S X="Function Findings:"
-        .D ^DIWP
-        .;Build the list of findings for this reminder.
-        .D BLDFLST^PXRMPTL(D0,.FL)
-        .S FILENUM="811.925",FINDING=0
-        .F  S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0  D
-        ..S FIND0=$G(^PXD(811.9,D0,25,FINDING,0))
-        ..S FIND3=$G(^PXD(811.9,D0,25,FINDING,3))
-        ..I FIND3="" Q
-        ..S FIELD=$P(FIND0,U,1)
-        ..S FINDNAM="FF("_FIELD_")"
-        ..S X=" "
-        ..D ^DIWP
-        ..S X=$$RJ^XLFSTR("---- Begin:",12,PAD)
-        ..S X=X_" "_FINDNAM
-        ..S LEN=(75-$L(X))
-        ..F INT=1:1:LEN S X=X_"-"
-        ..D ^DIWP
-        ..;
-        ..D SFDISP(FIND3,1,3,"Function String:",RJC,PAD,FILENUM)
-        ..S X="     Expanded Function String:" D ^DIWP
-        ..D DISLOGF^PXRMPTL(D0,FINDING,.FL,.PARRAY)
-        ..S INT=0
-        ..F  S INT=$O(PARRAY(INT)) Q:'INT  D
-        ...S X=$J("",6)_PARRAY(INT) D ^DIWP
-        ..;
-        ..S FIELD=$P(FIND0,U,4)
-        ..I $L(FIELD)>0 D
-        ...S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD)
-        ...S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0)
-        ...D ^DIWP
-        ..;
-        ..D SFDISP(FIND0,5,10,"Rank Frequency:",RJC,PAD,FILENUM)
-        ..D SFDISP(FIND0,6,11,"Use in Resolution Logic:",RJC,PAD,FILENUM)
-        ..D SFDISP(FIND0,7,12,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM)
-        ..;
-        ..D WPOUT(FINDING,25,"Found Text:",RJC,PAD,PADS,1)
-        ..D WPOUT(FINDING,25,"Not Found Text:",RJC,PAD,PADS,2)
-        ..S X=$$RJ^XLFSTR("---- End:",10,PADS)
-        ..S X=X_" "_FINDNAM_" "
-        ..S LEN=(75-$L(X))
-        ..F INT=1:1:(LEN) S X=X_"-"
-        ..D ^DIWP
-        ..S X=" "
-        ..D ^DIWP
-        ;
-        K ^TMP($J,"W")
-        ;^UTILITY($J,"W") will be killed by ^DIWW in the print template.
-        Q
-        ;
-        ;================================================
-RTERM   ;Reminder Term
-        N CNT,RJT,SCNT,SIEN,STAT0,TERM,TERM3,TERMNUM,TERMS
-        S CNT=0,RJT=RJC+10,TERMNUM="811.52"
-        S TERMS=0 F  S TERMS=$O(^PXRMD(811.5,IEN1,20,TERMS)) Q:+TERMS=0  D
-        .S TERM=$G(^PXRMD(811.5,IEN1,20,TERMS,0))
-        .S TERM3=$G(^PXRMD(811.5,IEN1,20,TERMS,3))
-        .D SFDISP(TERM,1,.01,"Mapped Finding Item:",RJT,PAD,TERMNUM,CNT)
-        .D SFDISP(TERM,8,9,"Beginning Date/Time:",RJT,PAD,TERMNUM)
-        .D SFDISP(TERM,9,10,"Use Inactive Problems:",RJT,PAD,TERMNUM)
-        .D SFDISP(TERM,11,12,"Ending Date/Time:",RJT,PAD,TERMNUM)
-        .D SFDISP(TERM,10,11,"Within Category Rank:",RJT,PAD,TERMNUM)
-        .D SFDISP(TERM,12,13,"MH Scale:",RJT,PAD,TERMNUM)
-        .D SFDISP(TERM,13,16,"RX Type:",RJT,PAD,TERMNUM)
-        .D SFDISP(TERM,14,17,"Occurrence Count:",RJT,PAD,TERMNUM)
-        .I $D(^PXRMD(811.5,IEN1,20,TERMS,5,0))=1 D
-        ..S (SCNT,SIEN)=0
-        ..F  S SIEN=$O(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN)) Q:SIEN=""  D
-        ...S STAT0=$G(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN,0))
-        ...D STATUS(STAT0,"Status List:",RJT) S SCNT=SCNT+1
-        .D SFDISP(TERM3,1,14,"Condition:",RJT,PAD,TERMNUM,1)
-        .D SFDISP(TERM3,2,15,"Condition Case Sensitive:",RJT,PAD,TERMNUM)
-        .D SFDISP(TERM3,3,18,"Use Status/Cond in Search:",RJT,PAD,TERMNUM)
-        .I $G(^PXRMD(811.5,IEN1,20,TERMS,15))'="" D 
-        ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJT,PAD)
-        ..S X=X_" "_$G(^PXRMD(811.5,IEN1,20,TERMS,15))
-        ..D ^DIWP
-        .S X=""
-        .D ^DIWP
-        .S CNT=CNT+1
-        I CNT=0 D  Q
-        .S X=$$RJ^XLFSTR("RT Mapped Finding:",RJC,PAD)
-        .S X=X_" No Reminder Finding Found"
-        .D ^DIWP
-        Q
-        ;
-        ;================================================
-SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG)    ;Standard finding
-        ;multiple field display.
-        N FIELD,HFCAT,HFIEN,NAME,TYPE,X
-        S NAME=""
-        S FIELD=$P(FIND0,U,PIECE)
-        I (PIECE=1)&(FLDNUM=".01")&(FILENUM="811.52") D
-        .I FLG=0 D
-        ..S X=""
-        ..D ^DIWP
-        ..S RTERM=$P($P(RFIND,"=",2),")")_")"
-        ..S X=$$RJ^XLFSTR("Mapped Findings:",40)
-        ..D ^DIWP
-        .S TYPE=$$FTYPE^PXRMPTD2(FIELD,1),NAME=$$ENTRYNAM^PXRMPTD2(FIELD)
-        .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)
-        .S X=X_" "_TYPE_"."_NAME
-        .D ^DIWP
-        .I TYPE="HF" D
-        ..S HFIEN=$P(TERM,";")
-        ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3)
-        ..S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U)
-        ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD)
-        ..S X=X_" "_HFCAT
-        ..D ^DIWP
-        I NAME'="" Q
-        I $L(FIELD)>0 D
-        .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)
-        .S X=X_" "_$$EXTERNAL^DILFD(FILENUM,FLDNUM,"",FIELD,"")
-        .I FLDNUM=13 S X=X_" - "_$$SPECIAL(FIND0,FIELD)
-        .D ^DIWP
-        Q
-        ;
-        ;================================================
-SPECIAL(FIND0,FIELD)    ;Special output for certain fields.
-        N FINDING,GLOBAL,IEN
-        S FINDING=$P(FIND0,U,1)
-        S IEN=$P(FINDING,";",1)
-        S GLOBAL=$P(FINDING,";",2)
-        I GLOBAL="YTT(601.71," Q $$SCNAME^PXRMMH(IEN,FIELD)
-        Q ""
-        ;
-        ;================================================
-STATUS(STAT0,TITLE,SPACE)       ;
-        I $L(STAT0)>0 D
-        .I SCNT=0 S X=$$RJ^XLFSTR(TITLE,SPACE,PAD)
-        .I SCNT>0 S X=$$RJ^XLFSTR("",SPACE,PAD)
-        .S X=X_" "_STAT0
-        .D ^DIWP
-        Q
-        ;
-        ;================================================
-WPFORMAT(FINDING,NODE,RJC,INDEX)        ;Format found/not found word processing text.
-        I '$D(^PXD(811.9,D0,NODE,FINDING,INDEX,1,0)) Q
-        ;Save the title using the current format for DIWP.
-        N DIWF,DIWL,DIWR,IND,NLINES,SC,X
-        K ^UTILITY($J,"W")
-        S DIWF="|",DIWL=RJC+2,DIWR=78
-        S IND=0
-        F  S IND=$O(^PXD(811.9,D0,NODE,FINDING,INDEX,IND)) Q:+IND=0  D
-        .S X=$G(^PXD(811.9,D0,NODE,FINDING,INDEX,IND,0))
-        .D ^DIWP
-        ;Find where this stuff went.
-        S SC=$O(^UTILITY($J,"W",""))
-        ;Save into ^TMP.
-        S NLINES=^UTILITY($J,"W",SC)
-        S ^TMP($J,"W",FINDING,NODE,INDEX)=NLINES
-        F IND=1:1:NLINES D
-        .S ^TMP($J,"W",FINDING,NODE,INDEX,IND)=^UTILITY($J,"W",SC,IND,0)
-        K ^UTILITY($J,"W")
-        Q
-        ;
-        ;================================================
-WPOUT(FINDING,NODE,TITLE,RJC,PAD,PADS,INDEX)    ;Output found/not found word processing
-        ;text.
-        I $D(^TMP($J,"W",FINDING,NODE,INDEX)) D
-        .N IND,X
-        .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)_" "_^TMP($J,"W",FINDING,NODE,INDEX,1)
-        .D ^DIWP
-        .F IND=2:1:^TMP($J,"W",FINDING,NODE,INDEX) D
-        ..S X=PADS_^TMP($J,"W",FINDING,NODE,INDEX,IND)
-        ..D ^DIWP
-        Q
-        ;
+PXRMPTDF ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;================================================
+PFIND ;Print the reminder definition finding multiple.
+ N DIWF,FIELD,FILENUM,FINDING,FIND0,FIND3,FINDNAM,FL,HFCAT,HFIEN
+ N IEN1,IND,INT,LEN,PAD,PADS,PARRAY,RJC,RFIND,RTERM,SCNT,SIEN,STAT0
+ ;If called by a FileMan print build the variable pointer list.
+ I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
+ ;No printing is done by PFIND it accumulates all output using ^DIWP.
+ ;The print template outputs the text with ^DIWW.
+ ;Because of the way DIWP works we need to format all the found and
+ ;not found text first and store it in ^TMP.
+ K ^TMP($J,"W")
+ S FILENUM="811.902"
+ S RJC=30,PAD=" ",PADS=""
+ F IND=1:1:(RJC+2) S PADS=PADS_PAD
+ S FINDING=0
+ F  S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0  D
+ .D WPFORMAT(FINDING,20,RJC,1)
+ .D WPFORMAT(FINDING,20,RJC,2)
+ K ^UTILITY($J,"W")
+ S FINDING=0
+ F  S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0  D
+ .D WPFORMAT(FINDING,25,RJC,1)
+ .D WPFORMAT(FINDING,25,RJC,2)
+ S DIWF="C80",DIWL=2
+ K ^UTILITY($J,"W")
+ S FINDING=0
+ F  S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0  D
+ .S FIND0=^PXD(811.9,D0,20,FINDING,0)
+ .S FIELD=$P(FIND0,U,1)
+ .S RTERM=FIELD
+ .S X=" "
+ .D ^DIWP
+ .S FINDNAM=$$ENTRYNAM^PXRMPTD2(FIELD)
+ .I FINDNAM="" S FINDNAM="?"
+ .S X=$$RJ^XLFSTR("---- Begin:",12,PAD)
+ .S X=X_" "_FINDNAM
+ .S RFIND=$$GENIEN^PXRMPTD2(FINDING)
+ .S X=X_" "_RFIND_" "
+ .S LEN=(75-$L(X))
+ .F INT=1:1:LEN S X=X_"-"
+ .D ^DIWP
+ .;
+ .S X=$$RJ^XLFSTR("Finding Type:",RJC,PAD)
+ .S X=X_" "_$$FTYPE^PXRMPTD2(FIELD,0)
+ .D ^DIWP
+ .I RFIND["HF" D
+ ..S HFIEN=$P($P($P(RFIND,"HF",2),"(",2),")")
+ ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3)
+ ..S HFCAT=$S(HFCAT="":"UNDEFINED",1:$P($G(^AUTTHF(HFCAT,0)),U,1))
+ ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD)
+ ..S X=X_" "_HFCAT
+ ..D ^DIWP
+ .;
+ .S FIELD=$P(FIND0,U,4)
+ .I $L(FIELD)>0 D
+ ..S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD)
+ ..S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0)
+ ..D ^DIWP
+ .;
+ .D SFDISP(FIND0,5,6,"Rank Frequency:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,6,7,"Use in Resolution Logic:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,7,8,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM)
+ .D DATE^PXRMPTD2(FIND0,8,9,"Beginning Date/Time:",RJC,PAD,FILENUM)
+ .D DATE^PXRMPTD2(FIND0,11,12,"Ending Date/Time:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD,FILENUM)
+ .I $D(^PXD(811.9,D0,20,FINDING,5,0))=1 D
+ ..S (SCNT,SIEN)=0
+ ..F  S SIEN=$O(^PXD(811.9,D0,20,FINDING,5,SIEN)) Q:SIEN=""  D
+ ...S STAT0=$G(^PXD(811.9,D0,20,FINDING,5,SIEN,0))
+ ...D STATUS(STAT0,"Status List:",RJC) S SCNT=SCNT+1
+ .S FIND0=$G(^PXD(811.9,D0,20,FINDING,3))
+ .D SFDISP(FIND0,1,14,"Condition:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,3,18,"Use Cond in Finding Search:",RJC,PAD,FILENUM)
+ .I $G(^PXD(811.9,D0,20,FINDING,15))'="" D 
+ ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
+ ..S X=X_" "_$G(^PXD(811.9,D0,20,FINDING,15))
+ ..D ^DIWP
+ .D WPOUT(FINDING,20,"Found Text:",RJC,PAD,PADS,1)
+ .D WPOUT(FINDING,20,"Not Found Text:",RJC,PAD,PADS,2)
+ .I RTERM["PXRMD(811.5" S IEN1=$P(RTERM,";") D RTERM
+ .S X=$$RJ^XLFSTR("---- End:",10,PADS)
+ .S X=X_" "_FINDNAM_" "
+ .S LEN=(75-$L(X))
+ .F INT=1:1:(LEN) S X=X_"-"
+ .D ^DIWP
+ .S X=" "
+ .D ^DIWP
+ ;
+ ;Function Findings
+ I +$P($G(^PXD(811.9,D0,25,0)),U,4)>0 D
+ .S X=" "
+ .D ^DIWP
+ .S X="Function Findings:"
+ .D ^DIWP
+ .;Build the list of findings for this reminder.
+ .D BLDFLST^PXRMPTL(D0,.FL)
+ .S FILENUM="811.925",FINDING=0
+ .F  S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0  D
+ ..S FIND0=$G(^PXD(811.9,D0,25,FINDING,0))
+ ..S FIND3=$G(^PXD(811.9,D0,25,FINDING,3))
+ ..I FIND3="" Q
+ ..S FIELD=$P(FIND0,U,1)
+ ..S FINDNAM="FF("_FIELD_")"
+ ..S X=" "
+ ..D ^DIWP
+ ..S X=$$RJ^XLFSTR("---- Begin:",12,PAD)
+ ..S X=X_" "_FINDNAM
+ ..S LEN=(75-$L(X))
+ ..F INT=1:1:LEN S X=X_"-"
+ ..D ^DIWP
+ ..;
+ ..D SFDISP(FIND3,1,3,"Function String:",RJC,PAD,FILENUM)
+ ..S X="     Expanded Function String:" D ^DIWP
+ ..D DISLOGF^PXRMPTL(D0,FINDING,.FL,.PARRAY)
+ ..S INT=0
+ ..F  S INT=$O(PARRAY(INT)) Q:'INT  D
+ ...S X=$J("",6)_PARRAY(INT) D ^DIWP
+ ..;
+ ..S FIELD=$P(FIND0,U,4)
+ ..I $L(FIELD)>0 D
+ ...S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD)
+ ...S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0)
+ ...D ^DIWP
+ ..;
+ ..D SFDISP(FIND0,5,10,"Rank Frequency:",RJC,PAD,FILENUM)
+ ..D SFDISP(FIND0,6,11,"Use in Resolution Logic:",RJC,PAD,FILENUM)
+ ..D SFDISP(FIND0,7,12,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM)
+ ..;
+ ..D WPOUT(FINDING,25,"Found Text:",RJC,PAD,PADS,1)
+ ..D WPOUT(FINDING,25,"Not Found Text:",RJC,PAD,PADS,2)
+ ..S X=$$RJ^XLFSTR("---- End:",10,PADS)
+ ..S X=X_" "_FINDNAM_" "
+ ..S LEN=(75-$L(X))
+ ..F INT=1:1:(LEN) S X=X_"-"
+ ..D ^DIWP
+ ..S X=" "
+ ..D ^DIWP
+ ;
+ K ^TMP($J,"W")
+ ;^UTILITY($J,"W") will be killed by ^DIWW in the print template.
+ Q
+ ;
+ ;================================================
+RTERM ;Reminder Term
+ N CNT,RJT,SCNT,SIEN,STAT0,TERM,TERM3,TERMNUM,TERMS
+ S CNT=0,RJT=RJC+10,TERMNUM="811.52"
+ S TERMS=0 F  S TERMS=$O(^PXRMD(811.5,IEN1,20,TERMS)) Q:+TERMS=0  D
+ .S TERM=$G(^PXRMD(811.5,IEN1,20,TERMS,0))
+ .S TERM3=$G(^PXRMD(811.5,IEN1,20,TERMS,3))
+ .D SFDISP(TERM,1,.01,"Mapped Finding Item:",RJT,PAD,TERMNUM,CNT)
+ .D SFDISP(TERM,8,9,"Beginning Date/Time:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM,9,10,"Use Inactive Problems:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM,11,12,"Ending Date/Time:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM,10,11,"Within Category Rank:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM,12,13,"MH Scale:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM,13,16,"RX Type:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM,14,17,"Occurrence Count:",RJT,PAD,TERMNUM)
+ .I $D(^PXRMD(811.5,IEN1,20,TERMS,5,0))=1 D
+ ..S (SCNT,SIEN)=0
+ ..F  S SIEN=$O(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN)) Q:SIEN=""  D
+ ...S STAT0=$G(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN,0))
+ ...D STATUS(STAT0,"Status List:",RJT) S SCNT=SCNT+1
+ .D SFDISP(TERM3,1,14,"Condition:",RJT,PAD,TERMNUM,1)
+ .D SFDISP(TERM3,2,15,"Condition Case Sensitive:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM3,3,18,"Use Cond in Finding Search:",RJT,PAD,TERMNUM)
+ .I $G(^PXRMD(811.5,IEN1,20,TERMS,15))'="" D 
+ ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJT,PAD)
+ ..S X=X_" "_$G(^PXRMD(811.5,IEN1,20,TERMS,15))
+ ..D ^DIWP
+ .S X=""
+ .D ^DIWP
+ .S CNT=CNT+1
+ I CNT=0 D  Q
+ .S X=$$RJ^XLFSTR("RT Mapped Finding:",RJC,PAD)
+ .S X=X_" No Reminder Finding Found"
+ .D ^DIWP
+ Q
+ ;
+ ;================================================
+SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard finding
+ ;multiple field display.
+ N FIELD,HFCAT,HFIEN,NAME,TYPE,X
+ S NAME=""
+ S FIELD=$P(FIND0,U,PIECE)
+ I (PIECE=1)&(FLDNUM=".01")&(FILENUM="811.52") D
+ .I FLG=0 D
+ ..S X=""
+ ..D ^DIWP
+ ..S RTERM=$P($P(RFIND,"=",2),")")_")"
+ ..S X=$$RJ^XLFSTR("Mapped Findings:",40)
+ ..D ^DIWP
+ .S TYPE=$$FTYPE^PXRMPTD2(FIELD,1),NAME=$$ENTRYNAM^PXRMPTD2(FIELD)
+ .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)
+ .S X=X_" "_TYPE_"."_NAME
+ .D ^DIWP
+ .I TYPE="HF" D
+ ..S HFIEN=$P(TERM,";")
+ ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3)
+ ..S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U)
+ ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD)
+ ..S X=X_" "_HFCAT
+ ..D ^DIWP
+ I NAME'="" Q
+ I $L(FIELD)>0 D
+ .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)
+ .S X=X_" "_$$EXTERNAL^DILFD(FILENUM,FLDNUM,"",FIELD,"")
+ .D ^DIWP
+ Q
+ ;
+ ;================================================
+STATUS(STAT0,TITLE,SPACE) ;
+ I $L(STAT0)>0 D
+ .I SCNT=0 S X=$$RJ^XLFSTR(TITLE,SPACE,PAD)
+ .I SCNT>0 S X=$$RJ^XLFSTR("",SPACE,PAD)
+ .S X=X_" "_STAT0
+ .D ^DIWP
+ Q
+ ;
+ ;================================================
+WPFORMAT(FINDING,NODE,RJC,INDEX) ;Format found/not found word processing text.
+ I '$D(^PXD(811.9,D0,NODE,FINDING,INDEX,1,0)) Q
+ ;Save the title using the current format for DIWP.
+ N DIWF,DIWL,DIWR,IND,NLINES,SC,X
+ K ^UTILITY($J,"W")
+ S DIWF="|",DIWL=RJC+2,DIWR=78
+ S IND=0
+ F  S IND=$O(^PXD(811.9,D0,NODE,FINDING,INDEX,IND)) Q:+IND=0  D
+ .S X=$G(^PXD(811.9,D0,NODE,FINDING,INDEX,IND,0))
+ .D ^DIWP
+ ;Find where this stuff went.
+ S SC=$O(^UTILITY($J,"W",""))
+ ;Save into ^TMP.
+ S NLINES=^UTILITY($J,"W",SC)
+ S ^TMP($J,"W",FINDING,NODE,INDEX)=NLINES
+ F IND=1:1:NLINES D
+ .S ^TMP($J,"W",FINDING,NODE,INDEX,IND)=^UTILITY($J,"W",SC,IND,0)
+ K ^UTILITY($J,"W")
+ Q
+ ;
+ ;================================================
+WPOUT(FINDING,NODE,TITLE,RJC,PAD,PADS,INDEX) ;Output found/not found word processing
+ ;text.
+ I $D(^TMP($J,"W",FINDING,NODE,INDEX)) D
+ .N IND,X
+ .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)_" "_^TMP($J,"W",FINDING,NODE,INDEX,1)
+ .D ^DIWP
+ .F IND=2:1:^TMP($J,"W",FINDING,NODE,INDEX) D
+ ..S X=PADS_^TMP($J,"W",FINDING,NODE,INDEX,IND)
+ ..D ^DIWP
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m

@@ -1 @@
-PXRMPTTR        ;SLC/PKR - Routines for term print templates ;06/01/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;====================================================
-DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG)      ;Standard DATE
-        N DATE,TEXT
-        S DATE=$P($G(FIND0),U,PIECE)
-        I DATE'="" D
-        . S DATE=$$FMTE^XLFDT(DATE,"D")
-        . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD)
-        . S TEXT=TEXT_" "_DATE
-        . W !,TEXT
-        Q
-        ;
-        ;====================================================
-GENIEN(FINDING) ;Return internal entry number for findings.
-        N F0,IEN,PREFIX,ROOT,VPTR
-        S ROOT="^PXRMD(811.5,D0,20,FINDING,0)"
-        S F0=@ROOT
-        S VPTR=$P(F0,U,1)
-        S IEN=$P(VPTR,";",1)
-        S ROOT=$P(VPTR,";",2)
-        I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
-        S VPTR=PXRMFVPL(ROOT)
-        S PREFIX=$P(VPTR,U,4)
-        Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))"
-        ;
-        ;====================================================
-ENTRYNAM(VPTR)  ;Given the variable pointer return the entry name. The
-        ;variable pointer list contains the information necessary to do the
-        ;look up.
-        N IEN,FILENUM,NAME,ROOT
-        S IEN=$P(VPTR,";",1)
-        S ROOT=$P(VPTR,";",2)
-        S FILENUM=$P(PXRMFVPL(ROOT),U,1)
-        S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","")
-        Q NAME
-        ;
-        ;====================================================
-PFIND   ;Print the reminder term finding multiple.
-        N CFP,FIELD,FINDING,FIND0,HFCAT,HFIEN,PAD,PXRMFVPL
-        N RJC,SCNT,SIEN,STAT0,TEXT
-        ;If called by a FileMan print build the variable pointer list.
-        I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
-        S PAD=" ",RJC=31
-        S FINDING=0
-        F  S FINDING=$O(^PXRMD(811.5,D0,20,FINDING)) Q:+FINDING=0  D
-        . S FIND0=^PXRMD(811.5,D0,20,FINDING,0)
-        . S FIELD=$P(FIND0,U,1)
-        . S TEXT=$$RJ^XLFSTR("Finding Item:",RJC,PAD)
-        . S TEXT=TEXT_"  "_$$ENTRYNAM(FIELD)
-        . S TEXT=TEXT_" "_$$TRMIEN(FINDING)
-        . W !!,TEXT
-        .;
-        . S TEXT=$$RJ^XLFSTR("Finding Type:",RJC,PAD)
-        . S TEXT=TEXT_"  "_$$TFTYPE(FIELD)
-        . W !,TEXT
-        . I FIND0["AUTTHF" D 
-        .. S HFIEN=$P($P(FIND0,U),";")
-        .. S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3)
-        .. S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U)
-        .. S TEXT=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD)
-        .. S TEXT=TEXT_"  "_HFCAT
-        .. W !,TEXT
-        .;
-        . S FIELD=$P(FIND0,U,4)
-        . I $L(FIELD)>0 D
-        .. S TEXT=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD)
-        .. S TEXT=TEXT_"  "_$$GENFREQ^PXRMPTD2(FIND0)
-        .. W !,TEXT
-        .;
-        . D DATE(FIND0,8,9,"Beginning Date/Time:",RJC,PAD)
-        . D DATE(FIND0,11,12,"Ending Date/Time Date:",RJC,PAD)
-        . D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD)
-        . D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD)
-        . D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD)
-        . D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD)
-        . D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD)
-        . D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD)
-        . D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD)
-        . I $D(^PXRMD(811.5,D0,20,FINDING,5,0))=1 D
-        .. S (SCNT,SIEN)=0
-        .. F  S SIEN=$O(^PXRMD(811.5,D0,20,FINDING,5,SIEN)) Q:SIEN=""  D
-        ... S STAT0=$G(^PXRMD(811.5,D0,20,FINDING,5,SIEN,0))
-        ... D STATUS(STAT0,"Status List:") S SCNT=SCNT+1
-        .;
-        . S FIND0=$G(^PXRMD(811.5,D0,20,FINDING,3))
-        . D SFDISP(FIND0,1,14,"Condition:",RJC,PAD)
-        . D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD)
-        . D SFDISP(FIND0,3,18,"Use Status/Cond in Search:",RJC,PAD)
-        . I $G(^PXRMD(811.5,D0,20,FINDING,15))'="" D
-        .. S CFP=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
-        .. S CFP=CFP_"  "_$G(^PXRMD(811.5,D0,20,FINDING,15))
-        .. W !,CFP
-        Q
-        ;
-        ;====================================================
-SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD)        ;Standard finding multiple
-        ;field display.
-        N FIELD,TEXT
-        S FIELD=$P(FIND0,U,PIECE)
-        I $L(FIELD)>0 D
-        . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD)
-        . S TEXT=TEXT_"  "_$$EXTERNAL^DILFD(811.52,FLDNUM,"",FIELD,"")
-        . I FLDNUM=13 S TEXT=TEXT_" - "_$$SPECIAL^PXRMPTDF(FIND0,FIELD)
-        . W !,TEXT
-        Q
-        ;
-        ;====================================================
-STATUS(STAT0,TITLE)     ; Status display
-        I $L(STAT0)>0 D
-        . N STATUS
-        . I SCNT=0 S STATUS=$$RJ^XLFSTR(TITLE,RJC,PAD)
-        . I SCNT>0 S STATUS=$$RJ^XLFSTR("",RJC,PAD)
-        . S STATUS=STATUS_"  "_STAT0
-        . W !,STATUS
-        Q
-        ;
-        ;====================================================
-TFTYPE(VPTR)    ;Return Term finding type
-        N ROOT,TFTYPE
-        S ROOT=$P(VPTR,";",2)
-        I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
-        S TFTYPE=$P(PXRMFVPL(ROOT),U,2)
-        Q TFTYPE
-        ;
-        ;====================================================
-TRMIEN(FINDING) ;Return internal entry number for TERM findings.
-        N F0,IEN,PREFIX,ROOT,VPTR
-        S ROOT="^PXRMD(811.5,D0,20,FINDING,0)"
-        S F0=@ROOT
-        S VPTR=$P(F0,U,1)
-        S IEN=$P(VPTR,";",1)
-        S ROOT=$P(VPTR,";",2)
-        I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
-        S VPTR=PXRMFVPL(ROOT)
-        S PREFIX=$P(VPTR,U,4)
-        Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))"
-        ;
+PXRMPTTR ;SLC/PKR - Routines for term print templates ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;====================================================
+DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard DATE
+ N DATE,TEXT
+ S DATE=$P($G(FIND0),U,PIECE)
+ I DATE'="" D
+ . S DATE=$$FMTE^XLFDT(DATE,"D")
+ . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD)
+ . S TEXT=TEXT_" "_DATE
+ . W !,TEXT
+ Q
+ ;
+ ;====================================================
+GENIEN(FINDING) ;Return internal entry number for findings.
+ N F0,IEN,PREFIX,ROOT,VPTR
+ S ROOT="^PXRMD(811.5,D0,20,FINDING,0)"
+ S F0=@ROOT
+ S VPTR=$P(F0,U,1)
+ S IEN=$P(VPTR,";",1)
+ S ROOT=$P(VPTR,";",2)
+ I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
+ S VPTR=PXRMFVPL(ROOT)
+ S PREFIX=$P(VPTR,U,4)
+ Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))"
+ ;
+ ;====================================================
+ENTRYNAM(VPTR) ;Given the variable pointer return the entry name. The
+ ;variable pointer list contains the information necessary to do the
+ ;look up.
+ N IEN,FILENUM,NAME,ROOT
+ S IEN=$P(VPTR,";",1)
+ S ROOT=$P(VPTR,";",2)
+ S FILENUM=$P(PXRMFVPL(ROOT),U,1)
+ S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","")
+ Q NAME
+ ;
+ ;====================================================
+PFIND ;Print the reminder term finding multiple.
+ N CFP,FIELD,FINDING,FIND0,HFCAT,HFIEN,PAD,PXRMFVPL
+ N RJC,SCNT,SIEN,STAT0,TEXT
+ ;If called by a FileMan print build the variable pointer list.
+ I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
+ S PAD=" ",RJC=31
+ S FINDING=0
+ F  S FINDING=$O(^PXRMD(811.5,D0,20,FINDING)) Q:+FINDING=0  D
+ . S FIND0=^PXRMD(811.5,D0,20,FINDING,0)
+ . S FIELD=$P(FIND0,U,1)
+ . S TEXT=$$RJ^XLFSTR("Finding Item:",RJC,PAD)
+ . S TEXT=TEXT_"  "_$$ENTRYNAM(FIELD)
+ . S TEXT=TEXT_" "_$$TRMIEN(FINDING)
+ . W !!,TEXT
+ .;
+ . S TEXT=$$RJ^XLFSTR("Finding Type:",RJC,PAD)
+ . S TEXT=TEXT_"  "_$$TFTYPE(FIELD)
+ . W !,TEXT
+ . I FIND0["AUTTHF" D 
+ .. S HFIEN=$P($P(FIND0,U),";")
+ .. S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3)
+ .. S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U)
+ .. S TEXT=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD)
+ .. S TEXT=TEXT_"  "_HFCAT
+ .. W !,TEXT
+ .;
+ . S FIELD=$P(FIND0,U,4)
+ . I $L(FIELD)>0 D
+ .. S TEXT=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD)
+ .. S TEXT=TEXT_"  "_$$GENFREQ^PXRMPTD2(FIND0)
+ .. W !,TEXT
+ .;
+ . D DATE(FIND0,8,9,"Beginning Date/Time:",RJC,PAD)
+ . D DATE(FIND0,11,12,"Ending Date/Time Date:",RJC,PAD)
+ . D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD)
+ . D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD)
+ . D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD)
+ . D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD)
+ . D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD)
+ . D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD)
+ . D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD)
+ . I $D(^PXRMD(811.5,D0,20,FINDING,5,0))=1 D
+ .. S (SCNT,SIEN)=0
+ .. F  S SIEN=$O(^PXRMD(811.5,D0,20,FINDING,5,SIEN)) Q:SIEN=""  D
+ ... S STAT0=$G(^PXRMD(811.5,D0,20,FINDING,5,SIEN,0))
+ ... D STATUS(STAT0,"Status List:") S SCNT=SCNT+1
+ .;
+ . S FIND0=$G(^PXRMD(811.5,D0,20,FINDING,3))
+ . D SFDISP(FIND0,1,14,"Condition:",RJC,PAD)
+ . D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD)
+ . D SFDISP(FIND0,3,18,"Use Cond in Finding Search:",RJC,PAD)
+ . I $G(^PXRMD(811.5,D0,20,FINDING,15))'="" D
+ .. S CFP=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
+ .. S CFP=CFP_"  "_$G(^PXRMD(811.5,D0,20,FINDING,15))
+ .. W !,CFP
+ Q
+ ;
+ ;====================================================
+SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD) ;Standard finding multiple
+ ;field display.
+ N FIELD,TEXT
+ S FIELD=$P(FIND0,U,PIECE)
+ I $L(FIELD)>0 D
+ . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD)
+ . S TEXT=TEXT_"  "_$$EXTERNAL^DILFD(811.52,FLDNUM,"",FIELD,"")
+ . W !,TEXT
+ Q
+ ;
+ ;====================================================
+STATUS(STAT0,TITLE) ; Status display
+ I $L(STAT0)>0 D
+ . N STATUS
+ . I SCNT=0 S STATUS=$$RJ^XLFSTR(TITLE,RJC,PAD)
+ . I SCNT>0 S STATUS=$$RJ^XLFSTR("",RJC,PAD)
+ . S STATUS=STATUS_"  "_STAT0
+ . W !,STATUS
+ Q
+ ;
+ ;====================================================
+TFTYPE(VPTR) ;Return Term finding type
+ N ROOT,TFTYPE
+ S ROOT=$P(VPTR,";",2)
+ I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
+ S TFTYPE=$P(PXRMFVPL(ROOT),U,2)
+ Q TFTYPE
+ ;
+ ;====================================================
+TRMIEN(FINDING) ;Return internal entry number for TERM findings.
+ N F0,IEN,PREFIX,ROOT,VPTR
+ S ROOT="^PXRMD(811.5,D0,20,FINDING,0)"
+ S F0=@ROOT
+ S VPTR=$P(F0,U,1)
+ S IEN=$P(VPTR,";",1)
+ S ROOT=$P(VPTR,";",2)
+ I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL)
+ S VPTR=PXRMFVPL(ROOT)
+ S PREFIX=$P(VPTR,U,4)
+ Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))"
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m

@@ -1 @@
-PXRMREDF        ; SLC/PJH - Edit PXRM reminder findings. ;01/09/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ; Called by PXRMREDT which newes and initialized DEF, DEF1, DEF2.
-        ;
-SET     S:'$D(^PXD(811.9,DA,20,0)) ^PXD(811.9,DA,20,0)="^811.902V" Q
-        ;Display ALL findings
-        ;
-        ;--------------------
-DSPALL(TYPE,NODE,DA,LIST)       ;
-        N FIRST,SUB,SUB1,SUB2
-        S FIRST=1,SUB="",SUB1="",SUB2=""
-        F  S SUB=$O(LIST(SUB)) Q:SUB=""  D
-        .S SUB1=0
-        .F  S SUB1=$O(LIST(SUB,SUB1)) Q:SUB1=""  D
-        ..S SUB2=0 F  S SUB2=$O(LIST(SUB,SUB1,SUB2)) Q:SUB2=""  D
-        ...I FIRST S FIRST=0 W !!,"Choose from:",!
-        ...W SUB
-        ...W ?5,SUB1,?65,"Finding #: "_SUB2,!
-        I FIRST,TYPE="D" W !!,"Reminder has no findings",!
-        I FIRST,TYPE="T" W !!,"Reminder Term has no findings",!
-        ;Update
-        D LIST^PXRMREDT(NODE,DA,.LIST)
-        Q
-        ;
-        ;Edit individual FINDING entry
-        ;-----------------------------
-FEDIT(IEN)      ;
-        N CFIEN,DA,DIC,DIE,DR,ETYPE,GLOB
-        N STATUS,TERMSTAT,TIEN,TERMTYPE,VF,WPIEN,Y
-        S DA(1)=IEN
-        S DIC="^PXD(811.9,"_IEN_",20,"
-        I $P(^PXD(811.9,IEN,100),U)="N",$G(PXRMINST)'=1 S DIC(0)="QEA"
-        E  S DIC(0)="QEAL"
-        S DIC("A")="Select FINDING: "
-        S DIC("P")="811.902V"
-        D ^DIC I Y=-1 S DTOUT=1 Q
-        S DIE=DIC K DIC
-        S DIE("NO^")="OUTOK"
-        S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
-        S TYPE=$G(DEF1(GLOB))
-        S SDA(2)=DA(1),SDA(1)=DA
-        ;Save term IEN
-        S STATUS=0
-        I TYPE="CF" S CFIEN=$P($P(Y,U,2),";",1) D
-        .I $D(^PXRMD(811.4,CFIEN,1))>0 D
-        ..W !!,"Computed Finding Description:" S WPIEN=0
-        ..F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
-        ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
-        .E  W !!,"No description defined for this computed finding"
-        I TYPE="MH" D WARN^PXRMMH
-        I TYPE="RT" S TIEN=$P($P(Y,U,2),";",1)
-        ;Finding record fields
-        W !!,"Editing Finding Number: "_$G(DA)
-        S DR=".01;3;I X=""0Y"" S Y=6;1;2;6;7;8;9;12;17"
-        ;Taxonomy - use inactive problems
-        I TYPE="TX" D
-        .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H")
-        .I TERMSTAT="P" S DR=DR_";10" Q
-        .I TERMSTAT'=0 S DR=DR_";10",STATUS=1
-        I TYPE="RT" D
-        .S TERMTYPE=$$TERMTYPE(TIEN)
-        .I TERMTYPE["H" S DR=DR_";11"
-        ;Health Factor - within category rank
-        I TYPE="HF" S DR=DR_";11"
-        ;If V file INCLUDE VISIT DATA
-        S VF=$S(TYPE="ED":1,TYPE="EX":1,TYPE="HF":1,TYPE="IM":1,TYPE="ST":1,TYPE="TX":1,1:0)
-        I TYPE="RT",$P(TERMTYPE,U,2)="VF" S VF=1
-        I VF S DR=DR_";28"
-        ;
-        ;Mental Health - scale
-        I TYPE="MH" S DR=DR_";13"
-        ;Radiology procedure.
-        I TYPE="RP" S STATUS=1
-        ;Orderable Item
-        I TYPE="OI" S DR=DR_";27",STATUS=1
-        ;Rx Type
-        I (TYPE="DC")!(TYPE="DG")!(TYPE="DR") S DR=DR_";16;27",STATUS=1
-        ;Condition
-        S DR=DR_";14;15;18"
-        I TYPE="CF" S DR=DR_";26"
-        ;Found/not found text
-        S DR=DR_";4;5"
-        ;
-        I TYPE="RT" D
-        . I TERMTYPE["D" S DR=DR_";16;27",STATUS=1
-        . I TERMTYPE["O" S DR=DR_";27",STATUS=1
-        . I TERMTYPE["R" S STATUS=1
-        . I TERMTYPE["T" S STATUS=1
-        .I TERMTYPE[2 D
-        .. N MSG
-        .. S MSG(1)="Cannot set a status since the term contains multiple types of findings"
-        .. S MSG(2)="Edit the status field at the term level for each finding" H 2
-        .. D EN^DDIOL(.MSG)
-        ;Edit finding record
-        D ^DIE
-        S $P(^PXD(811.9,IEN,20,0),U,3)=0
-        I $D(Y) S DTOUT=1 Q
-        ;Check if deleted
-        I '$D(DA) Q
-        I STATUS=1,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"D")
-        ;
-        S ETYPE=$P(^PXD(811.9,IEN,20,SDA(1),0),U,1)
-        ;Option to edit term findings
-        I $P(ETYPE,";",2)="PXRMD(811.5," D
-        . S TIEN=$P(ETYPE,";",1)
-        . D TMAP(IEN,TIEN)
-        Q
-        ;
-        ;Edit individual function finding entry
-        ;-----------------------------
-FFEDIT(IEN)     ;
-        N DA,DIC,DIE,DR,Y
-        S DA(1)=IEN
-        S DIC="^PXD(811.9,"_IEN_",25,"
-        S DIC(0)="QEAL"
-        S DIC("A")="Select FUNCTION FINDING: "
-        D ^DIC
-        I Y=-1 S DTOUT=1 Q
-        S DIE=DIC K DIC
-        S DA=+Y
-        ;Finding record fields
-        S DR=".01;3"
-        ;Edit finding record
-        D ^DIE
-        I $D(Y) S DTOUT=1 Q
-        I '$D(DA) Q
-        ;If the function string is null don't do the rest of the fields.
-        I $G(^PXD(811.9,IEN,25,DA,3))="" Q
-        S DR="1;2;11;12;15;I X=""0Y"" S Y=16;13;14;16"
-        D ^DIE
-        I $D(Y) S DTOUT=1 Q
-        I '$D(DA) Q
-        ;Check if deleted
-        Q
-        ;
-        ;Edit Reminder Function Findings
-        ;----------------------
-FFIND   ;
-        N DTOUT,DUOUT
-        F  D  Q:$D(DUOUT)!$D(DTOUT)
-        .D FFEDIT(DA) I $D(DUOUT)!$D(DTOUT) Q
-        K DUOUT,DTOUT
-        Q
-        ;
-        ;Edit Reminder Findings
-        ;----------------------
-FIND(LIST)      ;
-        N DTOUT,DUOUT,NODE,SDA
-        D SET ; Check if node defined
-        S NODE="^PXD(811.9)"
-        F  D  Q:$D(DUOUT)!$D(DTOUT)
-        .;Display list of existing reminder findings
-        .W !!,"Reminder Definition Findings"
-        .D DSPALL("D",NODE,DA,.LIST)
-        .;Edit findings
-        .D FEDIT(DA) I $D(DUOUT)!$D(DTOUT) D LIST^PXRMREDT(NODE,DA,.LIST) Q
-        .;Update list with finding changes
-        .D LIST^PXRMREDT(NODE,DA,.LIST)
-        Q
-        ;
-        ;General help text routine
-        ;-------------------------
-HELP(CALL)      ;
-        N HTEXT
-        N DIWF,DIWL,DIWR,IC
-        S DIWF="C70",DIWL=0,DIWR=70
-        ;
-        I CALL=1 D
-        .S HTEXT(1)="Select the type of finding you wish to change or add."
-        .S HTEXT(2)="Type '?' for a list of the available finding types."
-        I CALL=2 D
-        .S HTEXT(1)="Select section of the reminder you wish to edit or 'All'"
-        .S HTEXT(2)="to step through all sections of the reminder definition."
-        I CALL=3 D
-        .S HTEXT(1)="Select 'Y' to edit the findings mapped to this term"
-        .S HTEXT(2)="or 'N' to return to select another reminder finding."
-        ;
-        K ^UTILITY($J,"W")
-        S IC=""
-        F  S IC=$O(HTEXT(IC)) Q:IC=""  D
-        . S X=HTEXT(IC)
-        . D ^DIWP
-        W !
-        S IC=0
-        F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
-        . W !,^UTILITY($J,"W",0,IC,0)
-        K ^UTILITY($J,"W")
-        W !
-        Q
-        ;
-        ;Display TERM findings
-        ;--------------------
-TDSP(DA)        ;
-        N FIRST,SUB,TLST S FIRST=1,SUB="",SUB1=""
-        ;Build list of term findings
-        D TLST(.TLST,DA)
-        ;Display list
-        F  S SUB=$O(TLST(SUB)) Q:SUB=""  D
-        .S SUB1=0
-        .F  S SUB1=$O(TLST(SUB,SUB1)) Q:SUB1=""  D
-        ..I FIRST S FIRST=0 W !!,"Reminder Term Findings:",!!
-        ..W SUB
-        ..W ?8,SUB1,!
-        I FIRST W !!,"Term has no mapped findings",!!
-        Q
-        ;
-        ;List Reminders using this term
-        ;------------------------------
-TERMS(TIEN,RIEN)        ;
-        ;RIEN will be the reminder ien if called from reminder edit
-        ;or zero if called from term edit
-        N ARRAY,FIND,IEN,SUB,TCNT,RNAME
-        ;Scan all reminders in file #811.9
-        S IEN=0,FIND="PXRMD(811.5,",TCNT=0
-        F  S IEN=$O(^PXD(811.9,IEN)) Q:'IEN  D
-        .;Exclude current reminder called in reminder edit
-        .I RIEN,IEN=RIEN Q
-        .;Check the term findings
-        .I '$D(^PXD(811.9,IEN,20,"E",FIND,TIEN)) Q
-        .;Add to reminder array
-        .S RNAME=$P($G(^PXD(811.9,IEN,0)),U)
-        .I RNAME="" S RNAME=IEN
-        .I '$D(ARRAY(RNAME)) S TCNT=TCNT+1
-        .S ARRAY(RNAME)=""
-        ;
-        ;Display list of reminders using the term
-        I TCNT D
-        .N TXT
-        .S TXT="This Reminder Term is" S:RIEN TXT=TXT_" also"
-        .S TXT=TXT_" used by the following Reminder Definition"
-        .I TCNT>1 S TXT=TXT_"s"
-        .W !!,TXT_":"
-        .S RNAME="" F  S RNAME=$O(ARRAY(RNAME)) Q:RNAME=""  W !," ",RNAME
-        Q
-        ;
-        ;------------------------------
-        ;Check term for finding item to edit status item
-TERMTYPE(TIEN)  ;
-        N DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,TYPE,VF
-        S (DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,VF)=0
-        S TYPE="" F  S TYPE=$O(^PXRMD(811.5,TIEN,20,"B",TYPE)) Q:TYPE=""  D
-        . I TYPE["AUTTEDT(" S (OTHER,VF)=1 Q
-        . I TYPE["AUTTHF(" S (HF,OTHER,VF)=1 Q
-        . I TYPE["AUTTIMM(" S (OTHER,VF)=1 Q
-        . I TYPE["AUTTSK(" S (OTHER,VF)=1 Q
-        . I TYPE["ORD" S (ORD,FOUND)=1 Q
-        . I TYPE["PS" S (DRUG,FOUND)=1 Q
-        . I TYPE["PXD(811.2" S (FOUND,TAX,VF)=1 Q
-        . I TYPE["RAMIS" S (FOUND,RAD)=1 Q
-        . S OTHER=1
-        I RAD=1,ORD=0,TAX=0,DRUG=0,OTHER=0 S RESULT="R"
-        I RAD=0,ORD=1,TAX=0,DRUG=0,OTHER=0 S RESULT="O"
-        I RAD=0,ORD=0,TAX=1,DRUG=0,OTHER=0 S RESULT="T"
-        I RAD=0,ORD=0,TAX=0,DRUG=1,OTHER=0 S RESULT="D"
-        I OTHER=1 S RESULT=1 I FOUND=1 S RESULT=2
-        I RESULT="T" S RESULT=$$TAXTYPE^PXRMSTA1(TIEN,"")
-        I HF=1 S RESULT="H"_RESULT
-        I VF=1 S RESULT=RESULT_U_"VF"
-        Q RESULT
-        ;
-        ;Build list of mapped findings for term
-        ;--------------------------------------
-TLST(ARRAY,DA)  ;
-        N TYPE,DATA,GLOB,IEN,NAME,NODE,SUB
-        ;Clear passed arrays
-        K ARRAY
-        ;Build cross reference global to file number
-        ;Get each finding
-        S SUB=0 F  S SUB=$O(^PXRMD(811.5,DA,20,SUB)) Q:'SUB  D
-        .S DATA=$G(^PXRMD(811.5,DA,20,SUB,0)) I DATA="" Q
-        .;Determine global and global ien
-        .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";")
-        .;Ignore null entries
-        .I (GLOB="")!(IEN="") Q
-        .;Work out the file type
-        .S TYPE=$G(DEF1(GLOB)) Q:TYPE=""
-        .S NAME=$P($G(@(U_GLOB_IEN_",0)")),U)
-        .S ARRAY(TYPE,NAME)=""
-        Q
-        ;
-        ;Map Term findings
-        ;-----------------
-TMAP(RIEN,TIEN) ;
-        N TOPT,TNAM
-        ;Display any other reminders using this term
-        D TERMS(TIEN,RIEN)
-        ;Term name
-        S TNAM=$P($G(^PXRMD(811.5,TIEN,0)),U)
-        ;Give option to edit mapped findings (Y/N)
-        D TMASK(.TOPT,TNAM) Q:$D(DUOUT)!($D(DTOUT))
-        ;Edit term findings
-        I TOPT="Y" D TRMED(TIEN)
-        Q
-        ;
-        ;Option to edit term findings
-        ;----------------------------
-TMASK(YESNO,TNAM)       ;
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
-        S DIR(0)="YA0"
-        S DIR("A")="Do you want to edit mapped findings for "_TNAM_": "
-        S (DIR("B"),YESNO)="N"
-        S DIR("?")="Enter Y or N. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMREDF(3)"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        S YESNO=$E(Y(0))
-        Q
-        ;
-        ;Term edit
-        ;---------
-TRMED(DA)       ;
-        N CS1,CS2,DIC,DLAYGO,DTOUT,DUOUT,Y
-        K DLAYGO,DTOUT,DUOUT,Y
-        ;Display term findings
-        D TDSP(DA)
-        ;Initialize change history
-        S CS1=$$FILE^PXRMEXCS(811.5,DA)
-        ;Edit term findings
-        S DIC="^PXRMD(811.5,"
-        D EDIT^PXRMTMED(DIC,DA)
-        ;Update change history
-        S CS2=$$FILE^PXRMEXCS(811.5,DA)
-        I CS2=0 Q
-        I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
-        Q
-        ;
+PXRMREDF ; SLC/PJH - Edit PXRM reminder findings. ;02/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ; Called by PXRMREDT which newes and initialized DEF, DEF1, DEF2.
+ ;
+SET S:'$D(^PXD(811.9,DA,20,0)) ^PXD(811.9,DA,20,0)="^811.902V" Q
+ ;Display ALL findings
+ ;
+ ;--------------------
+DSPALL(TYPE,NODE,DA,LIST) ;
+ N FIRST,SUB,SUB1,SUB2
+ S FIRST=1,SUB="",SUB1="",SUB2=""
+ F  S SUB=$O(LIST(SUB)) Q:SUB=""  D
+ .S SUB1=0
+ .F  S SUB1=$O(LIST(SUB,SUB1)) Q:SUB1=""  D
+ ..S SUB2=0 F  S SUB2=$O(LIST(SUB,SUB1,SUB2)) Q:SUB2=""  D
+ ...I FIRST S FIRST=0 W !!,"Choose from:",!
+ ...W SUB
+ ...W ?5,SUB1,?65,"Finding #: "_SUB2,!
+ I FIRST,TYPE="D" W !!,"Reminder has no findings",!
+ I FIRST,TYPE="T" W !!,"Reminder Term has no findings",!
+ ;Update
+ D LIST^PXRMREDT(NODE,DA,.LIST)
+ Q
+ ;
+ ;Edit individual FINDING entry
+ ;-----------------------------
+FEDIT(IEN) ;
+ N CFIEN,DA,DIC,DIE,DR,ETYPE,GLOB
+ N STATUS,TERMSTAT,TIEN,TERMTYPE,VF,WPIEN,Y
+ S DA(1)=IEN
+ S DIC="^PXD(811.9,"_IEN_",20,"
+ I $P(^PXD(811.9,IEN,100),U)="N",$G(PXRMINST)'=1 S DIC(0)="QEA"
+ E  S DIC(0)="QEAL"
+ S DIC("A")="Select FINDING: "
+ S DIC("P")="811.902V"
+ D ^DIC I Y=-1 S DTOUT=1 Q
+ S DIE=DIC K DIC
+ S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
+ S TYPE=$G(DEF1(GLOB))
+ S SDA(2)=DA(1),SDA(1)=DA
+ ;Save term IEN
+ S STATUS=0
+ I TYPE="RT" S TIEN=$P($P(Y,U,2),";",1)
+ I TYPE="CF" S CFIEN=$P($P(Y,U,2),";",1) D
+ .I $D(^PXRMD(811.4,CFIEN,1))>0 D
+ ..W !!,"Computed Finding Description:" S WPIEN=0
+ ..F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
+ ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
+ .E  W !!,"No description defined for this computed finding"
+ ;Finding record fields
+ W !!,"Editing Finding Number: "_$G(DA)
+ S DR=".01;3;I X=""0Y"" S Y=6;1;2;6;7;8;9;12;17"
+ ;Taxonomy - use inactive problems
+ I TYPE="TX" D
+ .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H")
+ .I TERMSTAT="P" S DR=DR_";10" Q
+ .I TERMSTAT'=0 S DR=DR_";10",STATUS=1
+ I TYPE="RT" D
+ .S TERMTYPE=$$TERMTYPE(TIEN)
+ .I TERMTYPE["H" S DR=DR_";11"
+ ;Health Factor - within category rank
+ I TYPE="HF" S DR=DR_";11"
+ ;If V file INCLUDE VISIT DATA
+ S VF=$S(TYPE="ED":1,TYPE="EX":1,TYPE="HF":1,TYPE="IM":1,TYPE="ST":1,TYPE="TX":1,1:0)
+ I TYPE="RT",$P(TERMTYPE,U,2)="VF" S VF=1
+ I VF S DR=DR_";28"
+ ;
+ ;Mental Health - scale
+ I TYPE="MH" S DR=DR_";13"
+ ;Radiology procedure.
+ I TYPE="RP" S STATUS=1
+ ;Orderable Item
+ I TYPE="OI" S DR=DR_";27",STATUS=1
+ ;Rx Type
+ I (TYPE="DC")!(TYPE="DG")!(TYPE="DR") S DR=DR_";16;27",STATUS=1
+ ;Condition
+ S DR=DR_";14;15;18"
+ I TYPE="CF" S DR=DR_";26"
+ ;Found/not found text
+ S DR=DR_";4;5"
+ ;
+ I TYPE="RT" D
+ . I TERMTYPE["D" S DR=DR_";16;27",STATUS=1
+ . I TERMTYPE["O" S DR=DR_";27",STATUS=1
+ . I TERMTYPE["R" S STATUS=1
+ . I TERMTYPE["T" S STATUS=1
+ .I TERMTYPE[2 D
+ .. N MSG
+ .. S MSG(1)="Cannot set a status since the term contains multiple types of findings"
+ .. S MSG(2)="Edit the status field at the term level for each finding" H 2
+ .. D EN^DDIOL(.MSG)
+ ;Edit finding record
+ D ^DIE
+ S $P(^PXD(811.9,IEN,20,0),U,3)=0
+ I $D(Y) S DTOUT=1 Q
+ ;Check if deleted
+ I '$D(DA) Q
+ I STATUS=1 D STATUS^PXRMSTA1(.DA,"D")
+ ;
+ S ETYPE=$P(^PXD(811.9,IEN,20,SDA(1),0),U,1)
+ ;Option to edit term findings
+ I $P(ETYPE,";",2)="PXRMD(811.5," D
+ . S TIEN=$P(ETYPE,";",1)
+ . D TMAP(IEN,TIEN)
+ Q
+ ;
+ ;Edit individual function finding entry
+ ;-----------------------------
+FFEDIT(IEN) ;
+ N DA,DIC,DIE,DR,Y
+ S DA(1)=IEN
+ S DIC="^PXD(811.9,"_IEN_",25,"
+ S DIC(0)="QEAL"
+ S DIC("A")="Select FUNCTION FINDING: "
+ D ^DIC
+ I Y=-1 S DTOUT=1 Q
+ S DIE=DIC K DIC
+ S DA=+Y
+ ;Finding record fields
+ S DR=".01;3"
+ ;Edit finding record
+ D ^DIE
+ I $D(Y) S DTOUT=1 Q
+ I '$D(DA) Q
+ ;If the function string is null don't do the rest of the fields.
+ I $G(^PXD(811.9,IEN,25,DA,3))="" Q
+ S DR="1;2;11;12;15;I X=""0Y"" S Y=16;13;14;16"
+ D ^DIE
+ I $D(Y) S DTOUT=1 Q
+ I '$D(DA) Q
+ ;Check if deleted
+ Q
+ ;
+ ;Edit Reminder Function Findings
+ ;----------------------
+FFIND ;
+ N DTOUT,DUOUT
+ F  D  Q:$D(DUOUT)!$D(DTOUT)
+ .D FFEDIT(DA) I $D(DUOUT)!$D(DTOUT) Q
+ K DUOUT,DTOUT
+ Q
+ ;
+ ;Edit Reminder Findings
+ ;----------------------
+FIND(LIST) ;
+ N DTOUT,DUOUT,NODE,SDA
+ D SET ; Check if node defined
+ S NODE="^PXD(811.9)"
+ F  D  Q:$D(DUOUT)!$D(DTOUT)
+ .;Display list of existing reminder findings
+ .W !!,"Reminder Definition Findings"
+ .D DSPALL("D",NODE,DA,.LIST)
+ .;Edit findings
+ .D FEDIT(DA) I $D(DUOUT)!$D(DTOUT) D LIST^PXRMREDT(NODE,DA,.LIST) Q
+ .;Update list with finding changes
+ .D LIST^PXRMREDT(NODE,DA,.LIST)
+ Q
+ ;
+ ;General help text routine
+ ;-------------------------
+HELP(CALL) ;
+ N HTEXT
+ N DIWF,DIWL,DIWR,IC
+ S DIWF="C70",DIWL=0,DIWR=70
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="Select the type of finding you wish to change or add."
+ .S HTEXT(2)="Type '?' for a list of the available finding types."
+ I CALL=2 D
+ .S HTEXT(1)="Select section of the reminder you wish to edit or 'All'"
+ .S HTEXT(2)="to step through all sections of the reminder definition."
+ I CALL=3 D
+ .S HTEXT(1)="Select 'Y' to edit the findings mapped to this term"
+ .S HTEXT(2)="or 'N' to return to select another reminder finding."
+ ;
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
+ W !
+ Q
+ ;
+ ;Display TERM findings
+ ;--------------------
+TDSP(DA) ;
+ N FIRST,SUB,TLST S FIRST=1,SUB="",SUB1=""
+ ;Build list of term findings
+ D TLST(.TLST,DA)
+ ;Display list
+ F  S SUB=$O(TLST(SUB)) Q:SUB=""  D
+ .S SUB1=0
+ .F  S SUB1=$O(TLST(SUB,SUB1)) Q:SUB1=""  D
+ ..I FIRST S FIRST=0 W !!,"Reminder Term Findings:",!!
+ ..W SUB
+ ..W ?8,SUB1,!
+ I FIRST W !!,"Term has no mapped findings",!!
+ Q
+ ;
+ ;List Reminders using this term
+ ;------------------------------
+TERMS(TIEN,RIEN) ;
+ ;RIEN will be the reminder ien if called from reminder edit
+ ;or zero if called from term edit
+ N ARRAY,FIND,IEN,SUB,TCNT,RNAME
+ ;Scan all reminders in file #811.9
+ S IEN=0,FIND="PXRMD(811.5,",TCNT=0
+ F  S IEN=$O(^PXD(811.9,IEN)) Q:'IEN  D
+ .;Exclude current reminder called in reminder edit
+ .I RIEN,IEN=RIEN Q
+ .;Check the term findings
+ .I '$D(^PXD(811.9,IEN,20,"E",FIND,TIEN)) Q
+ .;Add to reminder array
+ .S RNAME=$P($G(^PXD(811.9,IEN,0)),U)
+ .I RNAME="" S RNAME=IEN
+ .I '$D(ARRAY(RNAME)) S TCNT=TCNT+1
+ .S ARRAY(RNAME)=""
+ ;
+ ;Display list of reminders using the term
+ I TCNT D
+ .N TXT
+ .S TXT="This Reminder Term is" S:RIEN TXT=TXT_" also"
+ .S TXT=TXT_" used by the following Reminder Definition"
+ .I TCNT>1 S TXT=TXT_"s"
+ .W !!,TXT_":"
+ .S RNAME="" F  S RNAME=$O(ARRAY(RNAME)) Q:RNAME=""  W !," ",RNAME
+ Q
+ ;
+ ;------------------------------
+ ;Check term for finding item to edit status item
+TERMTYPE(TIEN) ;
+ N DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,TYPE,VF
+ S (DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,VF)=0
+ S TYPE="" F  S TYPE=$O(^PXRMD(811.5,TIEN,20,"B",TYPE)) Q:TYPE=""  D
+ . I TYPE["AUTTEDT(" S (OTHER,VF)=1 Q
+ . I TYPE["AUTTHF(" S (HF,OTHER,VF)=1 Q
+ . I TYPE["AUTTIMM(" S (OTHER,VF)=1 Q
+ . I TYPE["AUTTSK(" S (OTHER,VF)=1 Q
+ . I TYPE["ORD" S (ORD,FOUND)=1 Q
+ . I TYPE["PS" S (DRUG,FOUND)=1 Q
+ . I TYPE["PXD(811.2" S (FOUND,TAX,VF)=1 Q
+ . I TYPE["RAMIS" S (FOUND,RAD)=1 Q
+ . S OTHER=1
+ I RAD=1,ORD=0,TAX=0,DRUG=0,OTHER=0 S RESULT="R"
+ I RAD=0,ORD=1,TAX=0,DRUG=0,OTHER=0 S RESULT="O"
+ I RAD=0,ORD=0,TAX=1,DRUG=0,OTHER=0 S RESULT="T"
+ I RAD=0,ORD=0,TAX=0,DRUG=1,OTHER=0 S RESULT="D"
+ I OTHER=1 S RESULT=1 I FOUND=1 S RESULT=2
+ I RESULT="T" S RESULT=$$TAXTYPE^PXRMSTA1(TIEN,"")
+ I HF=1 S RESULT="H"_RESULT
+ I VF=1 S RESULT=RESULT_U_"VF"
+ Q RESULT
+ ;
+ ;Build list of mapped findings for term
+ ;--------------------------------------
+TLST(ARRAY,DA) ;
+ N TYPE,DATA,GLOB,IEN,NAME,NODE,SUB
+ ;Clear passed arrays
+ K ARRAY
+ ;Build cross reference global to file number
+ ;Get each finding
+ S SUB=0 F  S SUB=$O(^PXRMD(811.5,DA,20,SUB)) Q:'SUB  D
+ .S DATA=$G(^PXRMD(811.5,DA,20,SUB,0)) I DATA="" Q
+ .;Determine global and global ien
+ .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";")
+ .;Ignore null entries
+ .I (GLOB="")!(IEN="") Q
+ .;Work out the file type
+ .S TYPE=$G(DEF1(GLOB)) Q:TYPE=""
+ .S NAME=$P($G(@(U_GLOB_IEN_",0)")),U)
+ .S ARRAY(TYPE,NAME)=""
+ Q
+ ;
+ ;Map Term findings
+ ;-----------------
+TMAP(RIEN,TIEN) ;
+ N TOPT,TNAM
+ ;Display any other reminders using this term
+ D TERMS(TIEN,RIEN)
+ ;Term name
+ S TNAM=$P($G(^PXRMD(811.5,TIEN,0)),U)
+ ;Give option to edit mapped findings (Y/N)
+ D TMASK(.TOPT,TNAM) Q:$D(DUOUT)!($D(DTOUT))
+ ;Edit term findings
+ I TOPT="Y" D TRMED(TIEN)
+ Q
+ ;
+ ;Option to edit term findings
+ ;----------------------------
+TMASK(YESNO,TNAM) ;
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S DIR(0)="YA0"
+ S DIR("A")="Do you want to edit mapped findings for "_TNAM_": "
+ S (DIR("B"),YESNO)="N"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMREDF(3)"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ S YESNO=$E(Y(0))
+ Q
+ ;
+ ;Term edit
+ ;---------
+TRMED(DA) ;
+ N CS1,CS2,DIC,DLAYGO,DTOUT,DUOUT,Y
+ K DLAYGO,DTOUT,DUOUT,Y
+ ;Display term findings
+ D TDSP(DA)
+ ;Initialize change history
+ S CS1=$$FILE^PXRMEXCS(811.5,DA)
+ ;Edit term findings
+ S DIC="^PXRMD(811.5,"
+ D EDIT^PXRMTMED(DIC,DA)
+ ;Update change history
+ S CS2=$$FILE^PXRMEXCS(811.5,DA)
+ I CS2=0 Q
+ I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m

@@ -1 @@
-PXRMREDT        ; SLC/PKR,PJH - Edit PXRM reminder definition. ;10/04/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=======================================================
-EEDIT   ;Entry point for PXRM DEFINITION EDIT option.
-        ;Build list of finding file definitions.
-        N DEF,DEF1,DEF2
-        D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
-        ;
-        N DA,DIC,DLAYGO,DTOUT,DUOUT,Y
-        S DIC="^PXD(811.9,"
-        S DIC(0)="AEMQL"
-        S DIC("A")="Select Reminder Definition: "
-        S DLAYGO=811.9
-GETNAME ;Get the name of the reminder definition to edit.
-        ;Set the starting place for additions.
-        D SETSTART^PXRMCOPY(DIC)
-        W !
-        S DIC("W")="W $$LUDISP^PXRMREDT(Y)"
-        D ^DIC
-        I ($D(DTOUT))!($D(DUOUT)) Q
-        I Y=-1 G END
-        S DA=$P(Y,U,1)
-        D ALL(DIC,DA)
-        G GETNAME
-END     ;
-        Q
-        ;
-        ;=======================================================
-        ;Select section of reminder to edit, also called at ALL by PXRMEDIT.
-        ;----------------------------------
-ALL(DIC,DA)     ;
-        ;Get list of findings/terms for reminder
-        N BLDLOGIC,CS1,CS2,LIST,NODE,OPTION,TYPE
-        S BLDLOGIC=0
-        ;Save the original checksum.
-        S CS1=$$FILE^PXRMEXCS(811.9,DA)
-        ;Build finding list
-        S NODE="^PXD(811.9)"
-        D LIST(NODE,DA,.LIST)
-        ;If this is a new reminder enter all fields
-        I $P(Y,U,3)=1 D EDIT(DIC,DA) Q 
-        ;National reminder allows editing of term findings only 
-        I '$$VEDIT^PXRMUTIL(DIC,DA) D  Q:$D(DUOUT)!$D(DTOUT)
-        .S TYPE=""
-        .F  S TYPE=$O(LIST(TYPE)) Q:TYPE=""  D
-        .. I TYPE="RT" Q
-        .. K LIST(TYPE)
-        .I '$D(LIST) S DUOUT=1 Q
-        .S BLDLOGIC=1
-        .D TFIND(DA,.LIST)
-        .I $D(Y) S DUOUT=1
-        ;Otherwise choose fields to edit
-        I $$VEDIT^PXRMUTIL(DIC,DA) F  D  Q:$D(DUOUT)!$D(DTOUT)
-        .D OPTION Q:$D(DUOUT)!$D(DTOUT)
-        .;All details
-        .I OPTION="A" D
-        .. S BLDLOGIC=1
-        .. D EDIT(DIC,DA)
-        .;Set up local variables
-        .N DIE,DR S DIE=DIC N DIC
-        .;Descriptions
-        .I OPTION="G" D
-        ..D GEN
-        .;Baseline Frequency
-        .I OPTION="B" D
-        ..S BLDLOGIC=1
-        ..D BASE
-        .;Findings
-        .I OPTION="F"  D
-        ..S BLDLOGIC=1
-        ..D FIND(.LIST)
-        .;Function findings
-        .I OPTION="FF"  D
-        ..S BLDLOGIC=1
-        ..D FFIND
-        .;Logic
-        .I OPTION="L" D
-        ..S BLDLOGIC=1
-        ..D LOGIC
-        .;Custom date due
-        . I OPTION="C" D
-        ..S BLDLOGIC=1
-        ..D CDUE
-        .;Dialog
-        .I OPTION="D" D
-        ..D DIALOG
-        .;Web addresses
-        .I OPTION="W" D
-        ..D WEB
-        .;If necessary build the internal logic strings.
-        .I BLDLOGIC D BLDALL^PXRMLOGX(DA,"","")
-        ;See if any changes have been made.
-        S CS2=$$FILE^PXRMEXCS(811.9,DA)
-        I CS2=0 Q
-        ;If the file has been edited, do the edit history.
-        I CS2'=CS1 D SEHIST^PXRMUTIL(811.9,DIC,DA)
-        Q
-        ;
-        ;Reminder Edit
-        ;-------------
-EDIT(ROOT,DA)   ;
-        N DIC,DIDEL,DIE,DR,RESULT
-        S DIE=ROOT,DIDEL=811.9
-        ;Edit the fields in the same order they are printed by a reminder
-        ;inquiry.
-        ;Reminder name
-        W !!
-        S DR=".01"
-        D ^DIE
-        ;If DA is undefined then the entry was deleted and we are done.
-        I '$D(DA) S DTOUT=1 Q
-        I $D(Y) S DTOUT=1 Q
-        ;
-        ;Other fields
-        D GEN Q:$D(Y)
-        D BASE Q:$D(Y)
-        D FIND(.LIST) Q:$D(Y)
-        D FFIND Q:$D(Y)
-        D LOGIC Q:$D(Y)
-        D DIALOG Q:$D(Y)
-        D WEB Q:$D(Y)
-        Q
-        ;
-GEN     ;Print name
-        W !!
-        S DR="1.2"
-        D ^DIE
-        I $D(Y) Q
-        ;
-CLASS   ;
-        ;Class
-        W !!
-        S DR="100"
-        D ^DIE
-        I $D(Y) Q
-        ;Sponsor
-        S DR="101"
-        D ^DIE
-        I $D(Y) Q
-        ;Make sure Class and Sponsor Class are in synch.
-        S RESULT=$$VSPONSOR^PXRMINTR(X)
-        I RESULT=0 G CLASS
-        ;Review date, Usage
-        S DR="102;103"
-        D ^DIE
-        I $D(Y) Q
-        ;
-        ;Related VA-* reminder
-        W !!
-        S DR="1.4"
-        D ^DIE
-        I $D(Y) Q
-        ;
-        ;Inactive flag
-        W !!
-        S DR="1.6"
-        D ^DIE
-        I $D(Y) Q
-        ;Ignore on N/A
-        S DR=1.8
-        D ^DIE
-        I $D(Y) Q
-        ;
-        ;Recision Date
-        S DR="69"
-        D ^DIE
-        I $D(Y) Q
-        ;
-        ;Reminder description
-        W !!
-        S DR="2"
-        D ^DIE
-        I $D(Y) Q
-        ;
-        ;Technical description
-        W !!
-        S DR="3"
-        D ^DIE
-        ;
-        ;Priority
-        W !!
-        S DR="1.91"
-        D ^DIE
-        Q
-        ;
-BASE    W !!,"Baseline Frequency"
-        ;Do in advance time frame
-        S DR=1.3
-        D ^DIE
-        I $D(Y) Q
-        ;
-        ;Sex specific
-        S DR=1.9
-        D ^DIE
-        I $D(Y) Q
-FARS    ;
-        W !!,"Baseline frequency age range set"
-        S DR="7"
-        S DR(2,811.97)=".01;1;2;3;4"
-        D ^DIE
-        I $$OVLAP^PXRMAGE G FARS
-        D SNMLA^PXRMFNFT(DA)
-        Q
-        ;
-FIND(LIST)      ;Edit findings (multiple)
-        D FIND^PXRMREDF(.LIST)
-        D SNMLF^PXRMFNFT(DA,20)
-        Q
-        ;
-FFIND   W !!,"Function Findings"
-        D FFIND^PXRMREDF
-        D SNMLF^PXRMFNFT(DA,25)
-        Q
-        ;
-LOGIC   W !!,"Patient Cohort and Resolution Logic"
-        S DR="30T;60T;61T;70T;71T;34T;65T;66T;75T;76T"
-        D ^DIE
-        ;Make sure the Patient Cohort Logic at least contains the default.
-        I $G(^PXD(811.9,DA,31))="" D
-        . S ^PXD(811.9,DA,31)="(SEX)&(AGE)"
-        . S ^PXD(811.9,DA,32)="2"_U_"SEX;AGE"
-        D SNMLL^PXRMFNFT(DA)
-        Q
-CDUE    W !!,"Custom Date Due"
-        S DR=45
-        D ^DIE
-        Q
-        ;
-DIALOG  W !!,"Reminder Dialog"
-        S DR="51"
-        D ^DIE
-        Q
-        ;
-WEB     W !!,"Web Addresses for Reminder Information"
-        S DR="50"
-        D ^DIE
-        Q
-        ;
-        ;Get full list of findings
-        ;-------------------------
-LIST(GBL,DA,ARRAY)      ;
-        N CNT,DATA,GLOB,IEN,NAME,NODE,SUB,TYPE
-        ;Clear passed arrays
-        K ARRAY
-        S CNT=0
-        ;Build cross reference global to file number
-        ;Get each finding
-        S SUB=0 F  S SUB=$O(@GBL@(DA,20,SUB)) Q:'SUB  D
-        .S DATA=$G(@GBL@(DA,20,SUB,0)) I DATA="" Q
-        .;Determine global and global ien
-        .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";")
-        .;Ignore null entries
-        .I (GLOB="")!(IEN="") Q
-        .;Work out the file type
-        .S TYPE=$G(DEF1(GLOB)) Q:TYPE=""
-        .S CNT=CNT+1
-        .I $P($G(@(U_GLOB_IEN_",0)")),U)="" D
-        ..W !,"**WARNING** Finding #"_SUB_" does not exist, select finding `"_SUB_" to edit it." Q
-        .E  S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=IEN
-        .;E  S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=$G(SUB)
-        Q
-        ;
-        ;Choose which part of Reminder to edit
-        ;-------------------------------------
-OPTION  N DIR,X,Y
-        ;Display warning message if un-mapped terms exist
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="SO"_U
-        S DIR(0)=DIR(0)_"A:All reminder details;"
-        S DIR(0)=DIR(0)_"G:General;"
-        S DIR(0)=DIR(0)_"B:Baseline Frequency;"
-        S DIR(0)=DIR(0)_"F:Findings;"
-        S DIR(0)=DIR(0)_"FF:Function Findings;"
-        S DIR(0)=DIR(0)_"L:Logic;"
-        S DIR(0)=DIR(0)_"C:Custom date due;"
-        S DIR(0)=DIR(0)_"D:Reminder Dialog;"
-        S DIR(0)=DIR(0)_"W:Web Addresses;"
-        S DIR("A")="Select section to edit"
-        S DIR("?")="Select which section of the reminder you wish to edit."
-        S DIR("??")="^D HELP^PXRMREDF(2)"
-        D ^DIR K DIR
-        I Y="" S DUOUT=1 Q
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!$D(DUOUT) Q
-        S OPTION=Y
-        Q
-        ;
-        ;-------------------------------------
-LUDISP(IEN)     ;Use for DIC("W") to augment look-up display.
-        N CLASS,EM,INACTIVE,TEXT
-        S INACTIVE=$P(^PXD(811.9,IEN,0),U,6)
-        S CLASS=$P(^PXD(811.9,IEN,100),U,1)
-        I INACTIVE'="" S INACTIVE="("_$$EXTERNAL^DILFD(811.9,1.6,"",INACTIVE,.EM)_")"
-        S CLASS=$$EXTERNAL^DILFD(811.9,100,"",CLASS,.EM)
-        S TEXT="  "_CLASS_" "_INACTIVE
-        Q TEXT
-        ;
-        ;-------------------------------------
-TFIND(DA,LIST)  ;Allow edit of term findings for national reminders.
-        N DIR,IENLIST,IND,JND,NAME,NAMELIST,SUB,X,Y
-        S IND=0,NAME=""
-        F  S NAME=$O(LIST("RT",NAME)) Q:NAME=""  D
-        . S IND=IND+1
-        . S NAMELIST(IND)=$$RJ^XLFSTR(IND,3)_" "_NAME
-        . S SUB=$O(LIST("RT",NAME,""))
-        . S IENLIST(IND)=LIST("RT",NAME,SUB)
-        M DIR("A")=NAMELIST
-        S DIR("A")="Enter your list"
-        S DIR(0)="LO^1:"_IND
-        W !!,"Select term(s) for finding edit:"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) S LIST="" Q
-        I $D(DUOUT)!$D(DTOUT) S LIST="" Q
-        F IND=1:1:$L(Y,",")-1 D
-        . S JND=$P(Y,",",IND)
-        . S NAME=$P(NAMELIST(JND),JND,2)
-        . W !!,"Reminder Term:",NAME
-        . D TMAP^PXRMREDF(DA,IENLIST(JND))
-        Q
-        ;
+PXRMREDT ; SLC/PKR,PJH - Edit PXRM reminder definition. ;02/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=======================================================
+EEDIT ;Entry point for PXRM DEFINITION EDIT option.
+ ;Build list of finding file definitions.
+ N DEF,DEF1,DEF2
+ D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
+ ;
+ N DA,DIC,DLAYGO,DTOUT,DUOUT,Y
+ S DIC="^PXD(811.9,"
+ S DIC(0)="AEMQL"
+ S DIC("A")="Select Reminder Definition: "
+ S DLAYGO=811.9
+GETNAME ;Get the name of the reminder definition to edit.
+ ;Set the starting place for additions.
+ D SETSTART^PXRMCOPY(DIC)
+ W !
+ D ^DIC
+ I ($D(DTOUT))!($D(DUOUT)) Q
+ I Y=-1 G END
+ S DA=$P(Y,U,1)
+ D ALL(DIC,DA)
+ G GETNAME
+END ;
+ Q
+ ;
+ ;=======================================================
+ ;Select section of reminder to edit, also called at ALL by PXRMEDIT.
+ ;----------------------------------
+ALL(DIC,DA) ;
+ ;Get list of findings/terms for reminder
+ N BLDLOGIC,CS1,CS2,LIST,NODE,OPTION,TYPE
+ S BLDLOGIC=0
+ ;Save the original checksum.
+ S CS1=$$FILE^PXRMEXCS(811.9,DA)
+ ;Build finding list
+ S NODE="^PXD(811.9)"
+ D LIST(NODE,DA,.LIST)
+ ;If this is a new reminder enter all fields
+ I $P(Y,U,3)=1 D EDIT(DIC,DA) Q 
+ ;National reminder allows editing of term findings only 
+ I '$$VEDIT^PXRMUTIL(DIC,DA) D  Q:$D(DUOUT)!$D(DTOUT)
+ .S TYPE=""
+ .F  S TYPE=$O(LIST(TYPE)) Q:TYPE=""  D
+ .. I TYPE="RT" Q
+ .. K LIST(TYPE)
+ .I '$D(LIST) S DUOUT=1 Q
+ .S BLDLOGIC=1
+ .D TFIND(DA,.LIST)
+ .I $D(Y) S DUOUT=1
+ ;Otherwise choose fields to edit
+ I $$VEDIT^PXRMUTIL(DIC,DA) F  D  Q:$D(DUOUT)!$D(DTOUT)
+ .D OPTION Q:$D(DUOUT)!$D(DTOUT)
+ .;All details
+ .I OPTION="A" D
+ .. S BLDLOGIC=1
+ .. D EDIT(DIC,DA)
+ .;Set up local variables
+ .N DIE,DR S DIE=DIC N DIC
+ .;Descriptions
+ .I OPTION="G" D
+ ..D GEN
+ .;Baseline Frequency
+ .I OPTION="B" D
+ ..S BLDLOGIC=1
+ ..D BASE
+ .;Findings
+ .I OPTION="F"  D
+ ..S BLDLOGIC=1
+ ..D FIND(.LIST)
+ .;Function findings
+ .I OPTION="FF"  D
+ ..S BLDLOGIC=1
+ ..D FFIND
+ .;Logic
+ .I OPTION="L" D
+ ..S BLDLOGIC=1
+ ..D LOGIC
+ .;Custom date due
+ . I OPTION="C" D
+ ..S BLDLOGIC=1
+ ..D CDUE
+ .;Dialog
+ .I OPTION="D" D
+ ..D DIALOG
+ .;Web addresses
+ .I OPTION="W" D
+ ..D WEB
+ .;If necessary build the internal logic strings.
+ .I BLDLOGIC D BLDALL^PXRMLOGX(DA,"","")
+ ;See if any changes have been made.
+ S CS2=$$FILE^PXRMEXCS(811.9,DA)
+ I CS2=0 Q
+ ;If the file has been edited, do the edit history.
+ I CS2'=CS1 D SEHIST^PXRMUTIL(811.9,DIC,DA)
+ Q
+ ;
+ ;Reminder Edit
+ ;-------------
+EDIT(ROOT,DA) ;
+ N DIC,DIDEL,DIE,DR,RESULT
+ S DIE=ROOT,DIDEL=811.9
+ ;Edit the fields in the same order they are printed by a reminder
+ ;inquiry.
+ ;Reminder name
+ W !!
+ S DR=".01"
+ D ^DIE
+ ;If DA is undefined then the entry was deleted and we are done.
+ I '$D(DA) S DTOUT=1 Q
+ I $D(Y) S DTOUT=1 Q
+ ;
+ ;Other fields
+ D GEN Q:$D(Y)
+ D BASE Q:$D(Y)
+ D FIND(.LIST) Q:$D(Y)
+ D FFIND Q:$D(Y)
+ D LOGIC Q:$D(Y)
+ D DIALOG Q:$D(Y)
+ D WEB Q:$D(Y)
+ Q
+ ;
+GEN ;Print name
+ W !!
+ S DR="1.2"
+ D ^DIE
+ I $D(Y) Q
+ ;
+CLASS ;
+ ;Class
+ W !!
+ S DR="100"
+ D ^DIE
+ I $D(Y) Q
+ ;Sponsor
+ S DR="101"
+ D ^DIE
+ I $D(Y) Q
+ ;Make sure Class and Sponsor Class are in synch.
+ S RESULT=$$VSPONSOR^PXRMINTR(X)
+ I RESULT=0 G CLASS
+ ;Review date, Usage
+ S DR="102;103"
+ D ^DIE
+ I $D(Y) Q
+ ;
+ ;Related VA-* reminder
+ W !!
+ S DR="1.4"
+ D ^DIE
+ I $D(Y) Q
+ ;
+ ;Inactive flag
+ W !!
+ S DR="1.6"
+ D ^DIE
+ I $D(Y) Q
+ ;Ignore on N/A
+ S DR=1.8
+ D ^DIE
+ I $D(Y) Q
+ ;
+ ;Recision Date
+ S DR="69"
+ D ^DIE
+ I $D(Y) Q
+ ;
+ ;Reminder description
+ W !!
+ S DR="2"
+ D ^DIE
+ I $D(Y) Q
+ ;
+ ;Technical description
+ W !!
+ S DR="3"
+ D ^DIE
+ ;
+ ;Priority
+ W !!
+ S DR="1.91"
+ D ^DIE
+ Q
+ ;
+BASE W !!,"Baseline Frequency"
+ ;Do in advance time frame
+ S DR=1.3
+ D ^DIE
+ I $D(Y) Q
+ ;
+ ;Sex specific
+ S DR=1.9
+ D ^DIE
+ I $D(Y) Q
+FARS ;
+ W !!,"Baseline frequency age range set"
+ S DR="7"
+ S DR(2,811.97)=".01;1;2;3;4"
+ D ^DIE
+ I $$OVLAP^PXRMAGE G FARS
+ D SNMLA^PXRMFNFT(DA)
+ Q
+ ;
+FIND(LIST) ;Edit findings (multiple)
+ D FIND^PXRMREDF(.LIST)
+ D SNMLF^PXRMFNFT(DA,20)
+ Q
+ ;
+FFIND W !!,"Function Findings"
+ D FFIND^PXRMREDF
+ D SNMLF^PXRMFNFT(DA,25)
+ Q
+ ;
+LOGIC W !!,"Patient Cohort and Resolution Logic"
+ S DR="30T;60T;61T;70T;71T;34T;65T;66T;75T;76T"
+ D ^DIE
+ ;Make sure the Patient Cohort Logic at least contains the default.
+ I $G(^PXD(811.9,DA,31))="" D
+ . S ^PXD(811.9,DA,31)="(SEX)&(AGE)"
+ . S ^PXD(811.9,DA,32)="2"_U_"SEX;AGE"
+ D SNMLL^PXRMFNFT(DA)
+ Q
+CDUE W !!,"Custom Date Due"
+ S DR=45
+ D ^DIE
+ Q
+ ;
+DIALOG W !!,"Reminder Dialog"
+ S DR="51"
+ D ^DIE
+ Q
+ ;
+WEB W !!,"Web Addresses for Reminder Information"
+ S DR="50"
+ D ^DIE
+ Q
+ ;
+ ;Get full list of findings
+ ;-------------------------
+LIST(GBL,DA,ARRAY) ;
+ N CNT,DATA,GLOB,IEN,NAME,NODE,SUB,TYPE
+ ;Clear passed arrays
+ K ARRAY
+ S CNT=0
+ ;Build cross reference global to file number
+ ;Get each finding
+ S SUB=0 F  S SUB=$O(@GBL@(DA,20,SUB)) Q:'SUB  D
+ .S DATA=$G(@GBL@(DA,20,SUB,0)) I DATA="" Q
+ .;Determine global and global ien
+ .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";")
+ .;Ignore null entries
+ .I (GLOB="")!(IEN="") Q
+ .;Work out the file type
+ .S TYPE=$G(DEF1(GLOB)) Q:TYPE=""
+ .S CNT=CNT+1
+ .I $P($G(@(U_GLOB_IEN_",0)")),U)="" D
+ ..W !,"**WARNING** Finding #"_SUB_" does not exist, select finding `"_SUB_" to edit it." Q
+ .E  S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=IEN
+ .;E  S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=$G(SUB)
+ Q
+ ;
+ ;Choose which part of Reminder to edit
+ ;-------------------------------------
+OPTION N DIR,X,Y
+ ;Display warning message if un-mapped terms exist
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="SO"_U
+ S DIR(0)=DIR(0)_"A:All reminder details;"
+ S DIR(0)=DIR(0)_"G:General;"
+ S DIR(0)=DIR(0)_"B:Baseline Frequency;"
+ S DIR(0)=DIR(0)_"F:Findings;"
+ S DIR(0)=DIR(0)_"FF:Function Findings;"
+ S DIR(0)=DIR(0)_"L:Logic;"
+ S DIR(0)=DIR(0)_"C:Custom date due;"
+ S DIR(0)=DIR(0)_"D:Reminder Dialog;"
+ S DIR(0)=DIR(0)_"W:Web Addresses;"
+ S DIR("A")="Select section to edit"
+ S DIR("?")="Select which section of the reminder you wish to edit."
+ S DIR("??")="^D HELP^PXRMREDF(2)"
+ D ^DIR K DIR
+ I Y="" S DUOUT=1 Q
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!$D(DUOUT) Q
+ S OPTION=Y
+ Q
+ ;
+ ;-------------------------------------
+TFIND(DA,LIST) ;Allow edit of term findings for national reminders.
+ N DIR,IENLIST,IND,NAME,NAMELIST,SUB,X,Y
+ S IND=0,NAME=""
+ F  S NAME=$O(LIST("RT",NAME)) Q:NAME=""  D
+ . S IND=IND+1
+ . S NAMELIST(IND)=$$RJ^XLFSTR(IND,3)_" "_NAME
+ . S SUB=$O(LIST("RT",NAME,""))
+ . S IENLIST(IND)=LIST("RT",NAME,SUB)
+ M DIR("A")=NAMELIST
+ S DIR("A")="Enter your list"
+ S DIR(0)="LO^1:"_IND
+ W !!,"Select term(s) for finding edit:"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) S LIST="" Q
+ I $D(DUOUT)!$D(DTOUT) S LIST="" Q
+ S LIST=Y
+ F IND=1:1:$L(Y,",")-1 D
+ . S NAME=$P(NAMELIST(IND),IND,2)
+ . W !!,"Reminder Term:",NAME
+ . D TMAP^PXRMREDF(DA,IENLIST(IND))
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m

@@ -1 @@
-PXRMRPCC        ;SLC/PJH - PXRM REMINDER DIALOG ;11/26/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-ACTIVE(ORY,ORREM)       ;Check if active dialog exist for reminders
-        ;
-        ; input parameter ORREM is array of reminder ien [.01#811.9]
-        N DDIS,DIEN,OCNT,RIEN,RSTA
-        S OCNT=0,RIEN=0
-        ;Get reminder ien from array
-        F  S RIEN=$O(ORREM(RIEN)) Q:'RIEN  D
-        .;Dialog ien for reminder
-        .S DIEN=$P($G(^PXD(811.9,RIEN,51)),U),RSTA=0
-        .;Dialog status
-        .I DIEN S DDIS=$P($G(^PXRMD(801.41,DIEN,0)),U,3)
-        .;If dialog and dialog not disabled
-        .I DIEN,DDIS="" S RSTA=1
-        .;Return reminder and if active dialog exists
-        .S OCNT=OCNT+1,ORY(OCNT)=RIEN_U_RSTA
-        Q
-        ;
-        ;
-DIALOG(ORY,ORREM,DFN)   ;Load reminder dialog associated with the reminder
-        ;
-        ; input parameter ORREM - reminder ien [.01,#811.9]
-        ;
-        S RIEN=ORREM
-        N DATA,DIEN
-        S DIEN=$G(^PXD(811.9,ORREM,51))
-        ;
-        ;Quit if no dialog for this reminder
-        I 'DIEN S ORY(1)="-1^no dialog for this reminder" Q
-        ;
-        ;Check if a reminder dialog and enabled
-        S DATA=$G(^PXRMD(801.41,DIEN,0))
-        ;
-        I $P(DATA,U,4)'="R" S ORY(1)="-1^reminder dialog invalid" Q
-        ;
-        I $P(DATA,U,3) S ORY(1)="-1^reminder dialog disabled" Q
-        ;
-        ;Load dialog lines into local array
-        S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17)
-        D LOAD^PXRMDLL(DIEN,$G(DFN))
-        Q
-        ;
-HDR(ORY,ORLOC)  ;Progress Note Header by location/service/user
-        N ORSRV,PASS
-        ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
-        S ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
-        S PASS=DUZ_";VA(200,"
-        I +$G(ORLOC) S PASS=PASS_"^LOC.`"_ORLOC
-        I ORSRV>0 S PASS=PASS_"^SRV.`"_+$G(ORSRV)
-        S ORY=$$GET^XPAR(PASS_"^DIV^SYS^PKG","PXRM PROGRESS NOTE HEADERS",1,"Q")
-        Q
-        ;
-PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ;Load additional prompts for a dialog element
-        ;
-        ; input parameters
-        ;
-        ; ORDLG  - dialog element ien [.01,#801.41]
-        ; ORDCUR - 0 = current, 1 = Historical for taxonomies only
-        ; ORFTYP - finding type (CPT/POV) for taxonomies only
-        ;
-        ; These fields can be found in the output array of DIALOG^PXRMRPCC
-        ;
-        D LOAD^PXRMDLLA(ORDLG,ORDCUR,$G(ORFTYP))
-        Q 
-        ;
-RES(ORY,ORREM)  ; Reminder Resources/Inquiry
-        ;
-        ; input parameter ORREM - reminder ien [.01,#811.9]
-        ;
-        D REMVAR^PXRMINQ(.ORY,ORREM)
-        Q
-        ;
-MH(ORY,OTEST)   ; Mental Health dialog
-        ;
-        ; Input mental health instrument NAME
-        ;
-        K ^TMP($J,"YSQU")
-        N ARRAY,CNT,CNT1,FNODE,FSUB,IC,NODE,OCNT,SUB,YS
-        ;DBIA #5056
-        S YS("CODE")=OTEST D SHOWALL^YTQPXRM5(.ARRAY,.YS)
-        S OCNT=0,CNT=0
-        S SUB="ARRAY",OCNT=0
-        F  S SUB=$Q(@SUB) Q:SUB=""  D
-        .S FSUB=$P($P(SUB,"(",2),")"),FNODE=""
-        .F IC=1:1 S NODE=$P(FSUB,",",IC) Q:NODE=""  D
-        ..I $E(NODE)="""" S NODE=$P(NODE,"""",2)
-        ..S $P(FNODE,";",IC)=NODE
-        .Q:FNODE=""
-        .S OCNT=OCNT+1,ORY(OCNT)=FNODE_U_@SUB
-        Q
-        ;
-MHR(ORY,RESULT,ORES)    ; Mental Health score and P/N text
-        ;
-        ; Input MH result IEN and mental health instrument response
-        ;
-        D START^PXRMDLR(.ORY,RESULT,.ORES)
-        ;
-        Q
-        ;
-MHS(ORY,YS)     ; Mental Health save response
-        ;
-        ; Input mental health instrument response
-        N ANS,ARRAY,X
-        S ANS=$G(YS("R1")) K YS("R1")
-        S YS("ADATE")=YS("ADATE")_"."_$P($$NOW^XLFDT,".",2)
-        F X=1:1:$L(ANS) I $E(ANS,X)'="X" S YS(X)=X_U_$E(ANS,X)
-        ;DBIA #4463
-        D SAVECR^YTQPXRM4(.ARRAY,.YS)
-        Q
-        ;
-MST(ORY,DFN,DGMSTDT,DGMSTSC,DGMSTPR,FTYP,FIEN,RESULT)   ; File MST status
-        ;This is obsolete and can be removed when the GUI is changed not
-        ;to use it.
-        Q
-        ;
-WH(ORY,RESULT)  ;
-        N CNT,CNT1,CNT2,NODE,PIECNT,PUR,TYPE,TYP1,WVIEN,WVRESULT,WVNOT,WVPURIEN
-        N PRINT
-        K ^TMP("WV RPT",$J)
-        I '$D(RESULT) Q
-        S (CNT2,WVPURIEN,PUR)=0
-        S CNT=0 F  S CNT=$O(RESULT(CNT)) Q:CNT=""  D
-        . I $P($G(RESULT(CNT)),U)["WHIEN" D
-        . . S CNT2=CNT2+1
-        . . S WVIEN=$P($P($G(RESULT(CNT)),U),":",2),WVRESULT(CNT2)=$G(WVIEN)
-        . . S WVRESULT(CNT2)=WVRESULT(CNT2)_U_$P($P($G(RESULT(CNT)),U,3),":",2)
-        . I $P($G(RESULT(CNT)),U)["WHPur" D
-        . . S NODE=$G(RESULT(CNT)),PUR=$P($P($G(NODE),U),":",2)
-        . . S CNT1=1,TYPE=$P($G(NODE),U,2)
-        . . I TYPE'[":" D
-        ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$P($G(NODE),U,2)_U_$P($G(NODE),U,3)_U_$P($P($G(NODE),U,4),":",2)
-        ..I TYPE[":" D
-        ...S PIECNT=0
-        ...F X=1:1:$L(TYPE) I $E(TYPE,X)=":" S PIECNT=PIECNT+1 I PIECNT>0 D
-        ....S PRINT=""
-        ....S TYP1=$P($G(TYPE),":",PIECNT)
-        ....I TYP1="L" S PRINT=$P($G(NODE),U,3)
-        ....S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2),CNT1=CNT1+1
-        ...S PIECNT=PIECNT+1
-        ...S PRINT=""
-        ...S TYP1=$P($G(TYPE),":",PIECNT)
-        ...I TYP1="L" S PRINT=$P($G(NODE),U,3)
-        ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2)
-        K WHMUFIND,WHFIND,WHNAME
-        ;DBIA #4104
-        D NEW^WVRPCNO(.WVRESULT,.WVNOT)
-        Q
-        ;
+PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;04/12/2002
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ACTIVE(ORY,ORREM) ;Check if active dialog exist for reminders
+ ;
+ ; input parameter ORREM is array of reminder ien [.01#811.9]
+ N DDIS,DIEN,OCNT,RIEN,RSTA
+ S OCNT=0,RIEN=0
+ ;Get reminder ien from array
+ F  S RIEN=$O(ORREM(RIEN)) Q:'RIEN  D
+ .;Dialog ien for reminder
+ .S DIEN=$P($G(^PXD(811.9,RIEN,51)),U),RSTA=0
+ .;Dialog status
+ .I DIEN S DDIS=$P($G(^PXRMD(801.41,DIEN,0)),U,3)
+ .;If dialog and dialog not disabled
+ .I DIEN,DDIS="" S RSTA=1
+ .;Return reminder and if active dialog exists
+ .S OCNT=OCNT+1,ORY(OCNT)=RIEN_U_RSTA
+ Q
+ ;
+ ;
+DIALOG(ORY,ORREM,DFN) ;Load reminder dialog associated with the reminder
+ ;
+ ; input parameter ORREM - reminder ien [.01,#811.9]
+ ;
+ S RIEN=ORREM
+ N DATA,DIEN
+ S DIEN=$G(^PXD(811.9,ORREM,51))
+ ;
+ ;Quit if no dialog for this reminder
+ I 'DIEN S ORY(1)="-1^no dialog for this reminder" Q
+ ;
+ ;Check if a reminder dialog and enabled
+ S DATA=$G(^PXRMD(801.41,DIEN,0))
+ ;
+ I $P(DATA,U,4)'="R" S ORY(1)="-1^reminder dialog invalid" Q
+ ;
+ I $P(DATA,U,3) S ORY(1)="-1^reminder dialog disabled" Q
+ ;
+ ;Load dialog lines into local array
+ D LOAD^PXRMDLL(DIEN,$G(DFN))
+ Q
+ ;
+HDR(ORY,ORLOC) ;Progress Note Header by location/service/user
+ N ORSRV,PASS
+ ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
+ S ORSRV=$$GET1^DIQ(200,DUZ,29,"I")
+ S PASS=DUZ_";VA(200,"
+ I +$G(ORLOC) S PASS=PASS_"^LOC.`"_ORLOC
+ I ORSRV>0 S PASS=PASS_"^SRV.`"_+$G(ORSRV)
+ S ORY=$$GET^XPAR(PASS_"^DIV^SYS^PKG","PXRM PROGRESS NOTE HEADERS",1,"Q")
+ Q
+ ;
+PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ;Load additional prompts for a dialog element
+ ;
+ ; input parameters
+ ;
+ ; ORDLG  - dialog element ien [.01,#801.41]
+ ; ORDCUR - 0 = current, 1 = Historical for taxonomies only
+ ; ORFTYP - finding type (CPT/POV) for taxonomies only
+ ;
+ ; These fields can be found in the output array of DIALOG^PXRMRPCC
+ ;
+ D LOAD^PXRMDLLA(ORDLG,ORDCUR,$G(ORFTYP))
+ Q 
+ ;
+RES(ORY,ORREM) ; Reminder Resources/Inquiry
+ ;
+ ; input parameter ORREM - reminder ien [.01,#811.9]
+ ;
+ D REMVAR^PXRMINQ(.ORY,ORREM)
+ Q
+ ;
+MH(ORY,OTEST) ; Mental Health dialog
+ ;
+ ; Input mental health instrument NAME
+ ;
+ N YS,ARRAY S YS("CODE")=OTEST D SHOWALL^YTAPI3(.ARRAY,.YS) ; DBIA #2895
+ ;
+ N FNODE,FSUB,IC,NODE,OCNT,SUB
+ S SUB="ARRAY",OCNT=0
+ F  S SUB=$Q(@SUB) Q:SUB=""  D
+ .S FSUB=$P($P(SUB,"(",2),")"),FNODE=""
+ .F IC=1:1 S NODE=$P(FSUB,",",IC) Q:NODE=""  D
+ ..I $E(NODE)="""" S NODE=$P(NODE,"""",2)
+ ..S $P(FNODE,";",IC)=NODE
+ .Q:FNODE=""
+ .S OCNT=OCNT+1,ORY(OCNT)=FNODE_U_@SUB
+ Q
+ ;
+MHR(ORY,RESULT,ORES) ; Mental Health score and P/N text
+ ;
+ ; Input MH result IEN and mental health instrument response
+ ;
+ D ^PXRMDLR
+ ;
+ Q
+ ;
+MHS(ORY,YS) ; Mental Health save response
+ ;
+ ; Input mental health instrument response
+ N ARRAY
+ D SAVEIT^YTAPI1(.ARRAY,.YS) ; DBIA #2893
+ I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2)
+ I ARRAY(1)="[DATA]" S ORY(1)=ARRAY(1)_ARRAY(2)
+ Q
+ ;
+MST(ORY,DFN,DGMSTDT,DGMSTSC,DGMSTPR,FTYP,FIEN,RESULT) ; File MST status
+ ;This is obsolete and can be removed when the GUI is changed not
+ ;to use it.
+ Q
+ ;
+WH(ORY,RESULT) ;
+ N CNT,CNT1,CNT2,NODE,PIECNT,PUR,TYPE,TYP1,WVIEN,WVRESULT,WVNOT,WVPURIEN
+ N PRINT
+ K ^TMP("WV RPT",$J)
+ I '$D(RESULT) Q
+ S (CNT2,WVPURIEN,PUR)=0
+ S CNT=0 F  S CNT=$O(RESULT(CNT)) Q:CNT=""  D
+ . I $P($G(RESULT(CNT)),U)["WHIEN" D
+ . . S CNT2=CNT2+1
+ . . S WVIEN=$P($P($G(RESULT(CNT)),U),":",2),WVRESULT(CNT2)=$G(WVIEN)
+ . . S WVRESULT(CNT2)=WVRESULT(CNT2)_U_$P($P($G(RESULT(CNT)),U,3),":",2)
+ . I $P($G(RESULT(CNT)),U)["WHPur" D
+ . . S NODE=$G(RESULT(CNT)),PUR=$P($P($G(NODE),U),":",2)
+ . . S CNT1=1,TYPE=$P($G(NODE),U,2)
+ . . I TYPE'[":" D
+ ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$P($G(NODE),U,2)_U_$P($G(NODE),U,3)_U_$P($P($G(NODE),U,4),":",2)
+ ..I TYPE[":" D
+ ...S PIECNT=0
+ ...F X=1:1:$L(TYPE) I $E(TYPE,X)=":" S PIECNT=PIECNT+1 I PIECNT>0 D
+ ....S PRINT=""
+ ....S TYP1=$P($G(TYPE),":",PIECNT)
+ ....I TYP1="L" S PRINT=$P($G(NODE),U,3)
+ ....S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2),CNT1=CNT1+1
+ ...S PIECNT=PIECNT+1
+ ...S PRINT=""
+ ...S TYP1=$P($G(TYPE),":",PIECNT)
+ ...I TYP1="L" S PRINT=$P($G(NODE),U,3)
+ ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2)
+ K WHMUFIND,WHFIND,WHNAME
+ ;DBIA #4104
+ D NEW^WVRPCNO(.WVRESULT,.WVNOT)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m

@@ -1 @@
-PXRMRUL1        ; SLC/AGP,PKR - Patient list routines. ; 03/29/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ;
-ASK(PLIEN,OPT)  ;Verify patient list name
-        N X,Y,TEXT
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="YA0"
-        S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
-        S DIR("B")="N"
-        S DIR("?")="Enter Y or N. For detailed help type ??"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        I $E(Y(0))="N" S DUOUT=1 Q
-        Q
-        ;
-COPY(IENO)      ;Copy patient list
-        ;Check if OK to copy
-        D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
-        N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
-        ;Select list to copy to
-        S TEXT="Select PATIENT LIST name to copy to: "
-        D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT)  Q:'IENN
-        S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
-        ;
-        ;Get original Patient List record 
-        S ODATA=$G(^PXRMXP(810.5,IENO,0))
-        S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
-        ;
-        M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
-        D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
-        ;Update header info
-        S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
-        S IND=IENN_","
-        S FDA(810.5,IND,.01)=NNAME
-        S FDA(810.5,IND,.04)=$$NOW^XLFDT
-        S FDA(810.5,IND,.05)=OEPIEN
-        S FDA(810.5,IND,.06)=ORULE
-        S FDA(810.5,IND,.07)=$G(DUZ)
-        S FDA(810.5,IND,.08)=TYPE
-        D UPDATE^DIE("","FDA","","MSG")
-        ;Error
-        I $D(MSG) D ERR
-        ;
-        W !!,"Completed copy of '"_ONAME_"'"
-        W !,"into '"_NNAME_"'",! H 2
-        K ^TMP($J,"PXRMRULE")
-        Q
-        ;
-CRLST(NAME,CLASS)       ;Create new patient list
-        N IEN
-        ;Check if name exists
-        S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
-        ;Otherwise create national entry
-        N FDA,FDAIEN,MSG
-        S FDA(810.5,"+1,",.01)=NAME
-        S FDA(810.5,"+1,",100)=CLASS
-        S FDA(810.5,"+1,",.07)=$G(DUZ)
-        ;Make stub public
-        S FDA(810.5,"+1,",.08)="PUB"
-        D UPDATE^DIE("","FDA","FDAIEN","MSG")
-        ;Error
-        I $D(MSG) Q 0
-        ;Otherwise list ien
-        Q FDAIEN(1)
-        ;
-COUNT(NODE)     ;Count the number of entries.
-        N DFN,NUM
-        S (DFN,NUM)=0
-        F  S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN=""  S NUM=NUM+1
-        Q NUM
-        ;
-DELETE(LIST)    ;Delete Patient list
-        I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D  Q
-        .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
-        .S DUOUT=1
-        ;Check if this is the right list
-        D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
-        ;
-        N DA,DIK,DUOUT
-        ;Lock patient list
-        D LOCK Q:$D(DUOUT)
-        ;Kill List
-        S DA=LIST,DIK="^PXRMXP(810.5,"
-        D ^DIK
-        ;Unlock patient list
-        D UNLOCK
-        Q
-        ;
-DATECHK(DATE)   ;
-        I DATE=0 Q 1
-        S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
-        Q $$VDT^PXRMINTR(DATE)
-        ;
-DATES(LBBDT,LBEDT,RBDT,REDT,FARR)       ;Set the dates in the finding array to
-        ;FileMan dates.
-        N FI,PXRMDATE,TBDT,TEDT
-        S FI=0
-        F  S FI=+$O(FARR(20,FI)) Q:FI=0  D
-        . S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)
-        . I TBDT="",TEDT="" D
-        .. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT
-        . E  D
-        .. S PXRMDATE=$S(TBDT["BDT":LBBDT,1:LBEDT)
-        .. S TBDT=$S(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
-        .. S PXRMDATE=$S(TEDT["BDT":LBBDT,1:LBEDT)
-        .. S TEDT=$S(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
-        .. S TEDT=$$CTFMD^PXRMDATE(TEDT)
-        .. S $P(FARR(20,FI,0),U,8)=TBDT,$P(FARR(20,FI,0),U,11)=TEDT
-        Q
-        ;
-ERR     ;Error Handler
-        N ERROR,IC,REF
-        S ERROR(1)="Unable to build patient list : "
-        S ERROR(2)=NAME
-        S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
-        ; Move MSG into Error
-        S REF="MSG"
-        F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
-        ;Screen message
-        D EN^DDIOL(.ERROR)
-        Q
-        ;
-INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP)     ;Save patient data.
-        I TFIEV(1)=0 Q
-        N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
-        S REF="TFIEV(1,""CSUB"")"
-        S PROOT=$P(REF,")",1)
-        ;Build the root so we can tell when we are done.
-        S TEMP=$NA(@REF)
-        S ROOT=$P(TEMP,")",1)
-        S REF=$Q(@REF)
-        I REF'[ROOT Q
-        S DONE=0
-        F  Q:(REF="")!(DONE)  D
-        . S START=$F(REF,ROOT)
-        . S LEN=$L(REF)-1
-        . S IND=$E(REF,START,LEN)
-        . S DATA(TNAME_IND)=@REF
-        . S REF=$Q(@REF)
-        . I REF'[ROOT S DONE=1
-        I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA
-        Q
-        ;
-INST(DFN)       ;Get the PCMM Institution.
-        N DATE,INST
-        ;Check PCMM
-        S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT)
-        ;DBIA #1916
-        S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
-        Q INST
-        ;
-LOCK    L +^PXRMXP(810.5,LIST):0
-        E  W !!?5,"Another user is using this patient list" S DUOUT=1
-        Q
-        ;
-LOGOP(LIST1,LIST2,LOGOP)        ;Given LIST1 and LIST2 apply the logical
-        ;operator LOGOP to generate a new list and return it in LIST1
-        N DFN1,DFN2
-        I LOGOP="&" D  Q
-        . S DFN1=""
-        . F  S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1=""  D
-        .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q
-        .. K ^TMP($J,LIST1,DFN1)
-        ;
-        ;"~" represents "&'".
-        I LOGOP="~" D  Q
-        . S DFN1=""
-        . F  S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1=""  D
-        .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1)
-        ;
-        I LOGOP="!" D
-        . S DFN2=""
-        . F  S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2=""  D
-        .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2)
-        Q
-        ;
-REM(FRACT,RIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE)  ;Process reminder finding rule
-        N DEFFARR,PXRMDATE
-        D DEF^PXRMLDR(RIEN,.DEFARR)
-        D DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
-        S PXRMDATE=RSTOP
-        D BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
-        ;Remove, Select or Add Findings operations
-        I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
-        I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q
-        I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q
-        Q
-        ;
-TERM(FRACT,FRTIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST)  ;Process TERM finding
-        ;rules
-        N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
-        N TERMARR,TFIEV,TNAME
-        ;Get term definition array
-        D TERM^PXRMLDR(FRTIEN,.TERMARR)
-        S TNAME=$P(TERMARR(0),U,1)
-        S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
-        ;Set begin and end dates in the term.
-        D DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
-        S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
-        ;
-        ;Add operation
-        I FRACT="A" D  Q
-        .;Process term for date range
-        .D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE)
-        .;Merge lists if operation is add
-        .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
-        ;Remove, Select or Insert Findings operations
-        I FRACT="F" S PXRMDEBG=1
-        S DFN=0
-        F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
-        .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q
-        .;Evaluate term
-        .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
-        .;Delete any ^TMP patient in PLIST if action is remove
-        .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q
-        .;Delete any ^TMP patient not in PLIST if action is select
-        .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q
-        .I FRACT="F",TFIEV(1) D
-        .. S FINDING=TFIEV(1,"FINDING")
-        .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
-        .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
-        .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
-        Q
-        ;
-UNLOCK  L -^PXRMXP(810.5,LIST) Q
-        ;
+PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 08/11/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+DATECHK(DATE) ;
+ I DATE=0 Q 1
+ S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
+ Q $$VDT^PXRMINTR(DATE)
+ ;
+INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
+ I TFIEV(1)=0 Q
+ N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP
+ S REF="TFIEV(1,""CSUB"")"
+ S PROOT=$P(REF,")",1)
+ ;Build the root so we can tell when we are done.
+ S TEMP=$NA(@REF)
+ S ROOT=$P(TEMP,")",1)
+ S REF=$Q(@REF)
+ I REF'[ROOT Q
+ S DONE=0
+ F  Q:(REF="")!(DONE)  D
+ . S START=$F(REF,ROOT)
+ . S LEN=$L(REF)-1
+ . S IND=$E(REF,START,LEN)
+ . S DATA(TNAME_IND)=@REF
+ . S REF=$Q(@REF)
+ . I REF'[ROOT S DONE=1
+ I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA
+ Q
+ ;
+INST(DFN) ;Get the PCMM Institution.
+ N DATE,INST
+ ;Check PCMM
+ S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT)
+ ;DBIA #1916
+ S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4)
+ Q INST
+ ;
+LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
+ ;operator LOGOP to generate a new list and return it in LIST1
+ N DFN1,DFN2
+ I LOGOP="&" D  Q
+ . S DFN1=""
+ . F  S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1=""  D
+ .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q
+ .. K ^TMP($J,LIST1,DFN1)
+ ;
+ ;"~" represents "&'".
+ I LOGOP="~" D  Q
+ . S DFN1=""
+ . F  S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1=""  D
+ .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1)
+ ;
+ I LOGOP="!" D
+ . S DFN2=""
+ . F  S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2=""  D
+ .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2)
+ Q
+ ;
+REM(FRACT,RIEN,RSTART,RSTOP,PNODE) ;Process reminder finding rule
+ D BLDPLST^PXRMPLST(RIEN,PNODE,1,RSTOP)
+ ;Remove, Select or Add Findings operations
+ I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
+ I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q
+ I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q
+ Q
+ ;
+TERM(FRACT,FRTIEN,RSTART,RSTOP,PNODE,INST) ;Process TERM finding rule
+ N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG,TERMARR,TFIEV,TNAME
+ ;Get term definition array
+ D TERM^PXRMLDR(FRTIEN,.TERMARR)
+ S TNAME=$P(TERMARR(0),U,1)
+ S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
+ ;Set start and end dates
+ S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
+ ;
+ ;Add operation
+ I FRACT="A" D  Q
+ .;Process term for date range
+ .D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PNODE)
+ .;Merge lists if operation is add
+ .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
+ ;Remove, Select or Insert Findings operations
+ I FRACT="F" S PXRMDEBG=1
+ S DFN=0
+ F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
+ .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q
+ .;Evaluate term
+ .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV)
+ .;Delete any ^TMP patient in PLIST if action is remove
+ .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q
+ .;Delete any ^TMP patient not in PLIST if action is select
+ .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q
+ .I FRACT="F",TFIEV(1) D
+ .. S FINDING=TFIEV(1,"FINDING")
+ .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING)
+ .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING)
+ .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m

@@ -1 @@
-PXRMRULE        ; SLC/PJH - Build Patient list from Rule Set ;03/27/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRM PATIENT LIST CREATE protocol
-        ;
-CLEAR(RULE,NODE)        ;Clear workfile entries
-        N SEQ
-        S SEQ=""
-        F  S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ  D
-        .K ^TMP($J,NODE_SEQ)
-        ;clear FDA array
-        K ^TMP($J,"PXRMFDA")
-        Q
-        ;
-INTR    ;Input transform for #810.4 fields
-        Q
-        ;
-LOAD(NODE,LIEN) ;Load Patient List
-        N DATA,DFN,SUB
-        S SUB=0
-        F  S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB  D
-        .S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN
-        .;Store the patient IEN and institution in ^TMP
-        .S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4)
-        Q
-        ;
-PATS(FRACT,FROUT,PNODE,LIST)    ;Process Patient List finding rule
-        ;
-        N LIEN,LUVALUE
-        ;Insert year and period into extract list name
-        I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
-        I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
-        ;
-        S LUVALUE(1)=LIST
-        S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN
-        ;
-        ;Add operation Load list
-        I FRACT="A" D LOAD(FROUT,LIEN) Q
-        ;
-        ;Remove or Select operations
-        ;Load List
-        D LOAD(PNODE,LIEN)
-        ;Check each patient
-        S DFN=0
-        F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
-        .;Delete any ^TMP patient in PLIST if action is remove
-        .I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
-        .;Delete any ^TMP patient not in PLIST if action is select
-        .I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
-        Q
-        ;
-START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP,EXTITR)   ;
-        ;Process rule set
-        ;Clear ^TMP
-        D CLEAR(RULESET,NODE)
-        ;
-        N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
-        N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
-        N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
-        ;Get class from extract parameter
-        I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U)
-        ;Otherwise default to local
-        I $G(CLASS)="" S CLASS="L"
-        ;PXRMDDOC=1 save list rule evaluation dates in ^TMP("PXRMDDOC",$J)
-        S PXRMDDOC=1
-        K ^TMP("PXRMDDOC",$J)
-        ;Get each finding rule in sequence
-        S SEQ="",INC=0,INST=0
-        F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
-        .;Save first sequence as default
-        .I INC=0 S INC=1,FSEQ=SEQ
-        .S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
-        .S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
-        .S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
-        .;Finding rule ien and action
-        .S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN  Q:FRACT=""
-        .;Check if entry is a finding rule (not a set or reminder rule)
-        .S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
-        .S FRDATES=$P(FRDATA,U,4,5)
-        .;Get term IEN for finding rule
-        .I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
-        .;Get Reminder definition IEN for Reminder rule
-        .I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
-        .;Get Extract Patient List name for patient list rule
-        .I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D  Q:FRLST=""
-        ..I +EXTITR>0 S FRLST=FRLST_"/"_EXTITR
-        ..S FROLST=$P(FRDATA,U,8)
-        ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
-        .;Determine RBDT and REDT
-        .D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
-        .S PXRMDATE=LBEDT
-        .;Get start sequence or start patient list
-        .S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5)
-        .;If sequence is defined use it
-        .I FRSTRT S FROUT=NODE_FRSTRT
-        .;If neither exist use first as default
-        .I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ
-        .;If start is patient list load patient list into workfile
-        .I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT)
-        .;Name of permanent list
-        .S FRPERM=$P(RSDATA,U,6)
-        .;
-        .;Build patient list in TMP
-        .N DFN,PNODE,TLIST
-        .S PNODE="PXRMEVAL"
-        .K ^TMP($J,PNODE)
-        .;Term finding rules
-        .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
-        .;Reminder Definition List Rule
-        .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
-        .;Patient list finding rules
-        .I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST)
-        .;Clear results file
-        .K ^TMP($J,PNODE)
-        .;
-        .;Build permanent list if required
-        .I FRPERM]"" D
-        ..N FRPIEN
-        ..;Get patient list IEN or create new patient list
-        ..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN
-        ..;Update patient list
-        ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
-        ;
-        ;Save final results to patient list
-        I LIST'="",FROUT'="" D
-        . D RMPAT^PXRMEUT(FROUT,INDP,INTP)
-        . D UPDLST(FROUT,LIST,PAR,RULESET,INST,INDP,INTP)
-        .;PXRMDDOC=2 compare saved dates with those generated in
-        .;DOCUMENT^PXRMEUT.
-        . S PXRMDDOC=2
-        . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
-        K ^TMP("PXRMDDOC",$J)
-        Q
-        ;
-UPDLST(NODE,LIST,EPIEN,RULE,INST,INDP,INTP)     ;Update patient list
-        N CNT,DA,DATA,DCNT,DECEASED,DFN,DNAME,DNAMEL,DOD,DUE,DUOUT,FDA
-        N INSTNAM,INSTNUM,LAST,MSG,NAME,ONODE
-        N RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TEST,TYPE,VALUE
-        ;Lock patient list
-        D LOCK^PXRMRUL1 Q:$D(DUOUT)
-        S TEMP=^PXRMXP(810.5,LIST,0)
-        S NAME=$P(TEMP,U,1)
-        S $P(^PXRMXP(810.5,LIST,0),U,11)=INDP
-        S $P(^PXRMXP(810.5,LIST,0),U,12)=INTP
-        ;
-        ;Clear existing list.
-        K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
-        ;
-        ;Merge ^TMP into Patient List
-        S (DECEASED,TESTP)=""
-        S (CNT,DFN)=0
-        F  S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN  D
-        .S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
-        .S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
-        .S TEMP=DFN_U_INSTNUM_U_INSTNAM
-        .I INDP D
-        ..;DBIA #10035
-        ..S DOD=+$P($G(^DPT(DFN,.35)),U,1)
-        ..S DECEASED=$S(DOD=0:0,1:1)
-        .;DBIA #3744
-        .I INTP S TESTP=$$TESTPAT^VADPT(DFN)
-        .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM_U_DECEASED_U_TESTP
-        .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
-        .;
-        .;Save the reminder evaluation information only from Reports
-        .I $D(^TMP($J,NODE,DFN,"REM"))>0 D
-        ..S (RIEN,RCNT,RNCNT)=0
-        ..F  S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0  D
-        ...S RNAMEL(RIEN)=""
-        ...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN)
-        ...S RCNT=RCNT+1
-        ...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
-        ...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
-        ..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
-        .;
-        .I '$D(^TMP($J,NODE,DFN,"DATA")) Q
-        .S DCNT=0,DNAME=""
-        .F  S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME=""  D
-        ..S DNAMEL(DNAME)=""
-        ..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME)
-        ..S DCNT=DCNT+1
-        ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
-        ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
-        .S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
-        S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
-        ;
-        ;Save the reminder information
-        S RNCNT=0,RIEN=0
-        F  S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0  D
-        .S RNCNT=RNCNT+1
-        .S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
-        .S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
-        I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
-        ;
-        ;Save the data types.
-        S DCNT=0,DNAME=""
-        F  S DNAME=$O(DNAMEL(DNAME)) Q:DNAME=""  D
-        .S DCNT=DCNT+1
-        .S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
-        .S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
-        I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
-        S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
-        ;
-        ;Update header info
-        S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
-        K PATCREAT
-        S FDA(810.5,"?+1,",.01)=NAME
-        S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
-        S FDA(810.5,"?+1,",.05)=EPIEN
-        S FDA(810.5,"?+1,",.06)=RULE
-        S FDA(810.5,"?+1,",.07)=$G(DUZ)
-        S FDA(810.5,"?+1,",.08)=TYPE
-        I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1
-        S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0)
-        D UPDATE^DIE("","FDA","","MSG")
-        ;Error
-        I $D(MSG) D ERR^PXRMRUL1
-        ;Unlock patient list
-        D UNLOCK^PXRMRUL1
-        Q
-        ;
+PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;08/11/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ; Called from PXRM PATIENT LIST CREATE protocol
+ ;
+ASK(PLIEN,OPT) ;Verify patient list name
+ N X,Y,TEXT
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="YA0"
+ S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
+ S DIR("B")="N"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ I $E(Y(0))="N" S DUOUT=1 Q
+ Q
+ ;
+CLEAR(RULE,NODE) ;Clear workfile entries
+ N SEQ
+ S SEQ=""
+ F  S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ  D
+ .K ^TMP($J,NODE_SEQ)
+ ;clear FDA array
+ K ^TMP($J,"PXRMFDA")
+ Q
+ ;
+COPY(IENO) ;Copy patient list
+ ;Check if OK to copy
+ D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
+ N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
+ ;Select list to copy to
+ S TEXT="Select PATIENT LIST name to copy to: "
+ D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT)  Q:'IENN
+ S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
+ ;
+ ;Get original Patient List record 
+ S ODATA=$G(^PXRMXP(810.5,IENO,0))
+ S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
+ ;
+ M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
+ D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
+ ;Update header info
+ S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
+ S IND=IENN_","
+ S FDA(810.5,IND,.01)=NNAME
+ S FDA(810.5,IND,.04)=$$NOW^XLFDT
+ S FDA(810.5,IND,.05)=OEPIEN
+ S FDA(810.5,IND,.06)=ORULE
+ S FDA(810.5,IND,.07)=$G(DUZ)
+ S FDA(810.5,IND,.08)=TYPE
+ D UPDATE^DIE("","FDA","","MSG")
+ ;Error
+ I $D(MSG) D ERR
+ ;
+ W !!,"Completed copy of '"_ONAME_"'"
+ W !,"into '"_NNAME_"'",! H 2
+ K ^TMP($J,"PXRMRULE")
+ Q
+ ;
+CRLST(NAME,CLASS) ;Create new patient list
+ N IEN
+ ;Check if name exists
+ S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
+ ;Otherwise create national entry
+ N FDA,FDAIEN,MSG
+ S FDA(810.5,"+1,",.01)=NAME
+ S FDA(810.5,"+1,",100)=CLASS
+ D UPDATE^DIE("","FDA","FDAIEN","MSG")
+ ;Error
+ I $D(MSG) Q 0
+ ;Otherwise list ien
+ Q FDAIEN(1)
+ ;
+DELETE(LIST) ;Delete Patient list
+ I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D  Q
+ .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
+ .S DUOUT=1
+ ;Check if this is the right list
+ D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ N DA,DIK,DUOUT
+ ;Lock patient list
+ D LOCK Q:$D(DUOUT)
+ ;Kill List
+ S DA=LIST,DIK="^PXRMXP(810.5,"
+ D ^DIK
+ ;Unlock patient list
+ D UNLOCK
+ Q
+ ;
+ERR ;Error Handler
+ N ERROR,IC,REF
+ S ERROR(1)="Unable to build patient list : "
+ S ERROR(2)=NAME
+ S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
+ ; Move MSG into Error
+ S REF="MSG"
+ F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
+ ;Screen message
+ D EN^DDIOL(.ERROR)
+ Q
+ ;
+INTR ;Input transform for #810.4 fields
+ Q
+ ;
+LOAD(NODE,LIEN) ;Load Patient List
+ N DATA,DFN,SUB
+ S SUB=0
+ F  S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB  D
+ .S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN
+ .;Store the patient IEN and institution in ^TMP
+ .S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4)
+ Q
+ ;
+LOCK L +^PXRMXP(810.5,LIST):0
+ E  W !!?5,"Another user is using this patient list" S DUOUT=1
+ Q
+ ;
+PATS(LIST) ;Process Patient List finding rule
+ ;
+ N LIEN,LUVALUE
+ ;Insert year and period into extract list name
+ I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
+ I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
+ ;
+ S LUVALUE(1)=LIST
+ S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN
+ ;
+ ;Add operation Load list
+ I FRACT="A" D LOAD(FROUT,LIEN) Q
+ ;
+ ;Remove, Select or Add Findings operations
+ I FRACT'="A" D  Q
+ .;Load List
+ .D LOAD(PNODE,LIEN)
+ .;Check each patient
+ .S DFN=0
+ .F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
+ ..;Delete any ^TMP patient in PLIST if action is remove
+ ..I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
+ ..;Delete any ^TMP patient not in PLIST if action is select
+ ..I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
+ Q
+ ;
+START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP) ;
+ ;Process rule set
+ ;Clear ^TMP
+ D CLEAR(RULESET,NODE)
+ ;
+ N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE
+ N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
+ ;Get class from extract parameter
+ I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U)
+ ;Otherwise default to local
+ I $G(CLASS)="" S CLASS="L"
+ ;Get each finding rule in sequence
+ S SEQ="",INC=0
+ F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
+ .;Save first sequence as default
+ .I INC=0 S INC=1,FSEQ=SEQ
+ .S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
+ .S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
+ .S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
+ .;Finding rule ien and action
+ .S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN  Q:FRACT=""
+ .;Check if entry is a finding rule (not a set or reminder rule)
+ .S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
+ .S FRDATES=$P(FRDATA,U,4,5)
+ .;Get term IEN for finding rule
+ .I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
+ .;Get Reminder definition IEN for Reminder rule
+ .I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
+ .;Get Extract Patient List name for patient list rule
+ .I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D  Q:FRLST=""
+ ..S FROLST=$P(FRDATA,U,8)
+ ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
+ .;Determine RBDT and REDT
+ .D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
+ .S PXRMDATE=LBEDT
+ .;Get start sequence or start patient list
+ .S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5)
+ .;If sequence is defined use it
+ .I FRSTRT S FROUT=NODE_FRSTRT
+ .;If neither exist use first as default
+ .I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ
+ .;If start is patient list load patient list into workfile
+ .I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT)
+ .;Name of permanent list
+ .S FRPERM=$P(RSDATA,U,6)
+ .;
+ .;Build patient list in TMP
+ .N DFN,PNODE,TLIST
+ .S PNODE="PXRMEVAL"
+ .K ^TMP($J,PNODE)
+ .;Term finding rules
+ .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,RBDT,REDT,PNODE,.INST)
+ .;Reminder Definition List Rule
+ .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,RBDT,REDT,PNODE)
+ .;Patient list finding rules
+ .I FRTYP=5 D PATS(FRLST)
+ .;Clear results file
+ .K ^TMP($J,PNODE)
+ .;
+ .;Build permanent list if required
+ .I FRPERM]"" D
+ ..N FRPIEN
+ ..;Get patient list IEN or create new patient list
+ ..S FRPIEN=$$CRLST(FRPERM,CLASS) Q:'FRPIEN
+ ..;Update patient list
+ ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST)
+ ;
+ ;Save final results to patient list
+ I LIST'="",FROUT'="" D
+ . D RMPAT^PXRMEUT(FROUT,INDP,INTP)
+ . D UPDLST(FROUT,LIST,PAR,RULESET,INST)
+ . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
+ Q
+ ;
+UPDLST(NODE,LIST,EPIEN,RULE,INST) ;Update patient list
+ N CNT,DA,DATA,DCNT,DFN,DNAME,DNAMEL,DUE,DUOUT,FDA,INST,INSTNAM,INSTNUM
+ N LAST,MSG,NAME,ONODE,RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TYPE,VALUE
+ ;Lock patient list
+ D LOCK Q:$D(DUOUT)
+ ;
+ ;Clear existing list.
+ K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
+ S NAME=$P($G(^PXRMXP(810.5,LIST,0)),U)
+ ;
+ ;Merge ^TMP into Patient List
+ S (CNT,DFN,INST)=0
+ F  S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN  D
+ .S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
+ .S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
+ .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM
+ .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
+ .;
+ .;Save the reminder evaluation information only from Reports
+ .I $D(^TMP($J,NODE,DFN,"REM"))>0 D
+ ..S (RIEN,RCNT,RNCNT)=0
+ ..F  S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0  D
+ ...S RNAMEL(RIEN)=""
+ ...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN)
+ ...S RCNT=RCNT+1
+ ...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
+ ...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
+ ..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
+ .;
+ .I '$D(^TMP($J,NODE,DFN,"DATA")) Q
+ .S DCNT=0,DNAME=""
+ .F  S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME=""  D
+ ..S DNAMEL(DNAME)=""
+ ..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME)
+ ..S DCNT=DCNT+1
+ ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
+ ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
+ .S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
+ S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
+ ;
+ ;Save the reminder information
+ S RNCNT=0,RIEN=0
+ F  S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0  D
+ .S RNCNT=RNCNT+1
+ .S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
+ .S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
+ I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
+ ;
+ ;Save the data types.
+ S DCNT=0,DNAME=""
+ F  S DNAME=$O(DNAMEL(DNAME)) Q:DNAME=""  D
+ .S DCNT=DCNT+1
+ .S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
+ .S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
+ I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
+ S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
+ ;
+ ;Update header info
+ S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
+ K PATCREAT
+ S FDA(810.5,"?+1,",.01)=NAME
+ S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
+ S FDA(810.5,"?+1,",.05)=EPIEN
+ S FDA(810.5,"?+1,",.06)=RULE
+ S FDA(810.5,"?+1,",.07)=$G(DUZ)
+ S FDA(810.5,"?+1,",.08)=TYPE
+ I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1
+ S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0)
+ D UPDATE^DIE("","FDA","","MSG")
+ ;Error
+ I $D(MSG) D ERR
+ ;Unlock patient list
+ D UNLOCK
+ Q
+ ;
+UNLOCK L -^PXRMXP(810.5,LIST) Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m

@@ -1 @@
-PXRMSTA1        ; SLC/AGP - Routines for building status list. ;09/06/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;This routine and PXRMSTA2 will allow users to select the
-        ;approriate status for Orders, Medication, Taxonomy, Problem List,
-        ;and Radiology Procedure findings items.
-        ;
-CLEAR(GBL,FILE,DA)      ;
-        N IEN,NODE,DIK,TEMP
-        I FILE="D" S DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5,"
-        I FILE="T" S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5,"
-        S DA=0 F  S DA=$O(@GBL@(DA(2),20,DA(1),5,DA)) Q:DA'>0  S TEMP(DA)=""
-        S DA=0 F  S DA=$O(TEMP(DA)) Q:DA'>0  D ^DIK
-        Q
-        ;
-STATUS(DA,FILE) ;
-        N ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE
-        N RXTYPE,TAXNODE,TERMTYPE,Y
-        N CSTATUS,UPDATE,HTEXT,OSTAUS,WILD
-        S DA(2)=DA(1),DA(1)=DA,DA="",UPDATE=0,DELALL=0
-        I FILE="D" S GBL="^PXD(811.9)"
-        I FILE="T" S GBL="^PXRMD(811.5)"
-        S NODE=$G(@GBL@(DA(2),20,DA(1),0))
-        S TYPE=$P($G(@GBL@(DA(2),20,DA(1),0)),U)
-        S WILD=0
-        ;check for current defined statuses if none set the default values
-        I FILE="D",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0 D DEFAULT(GBL,TYPE,NODE,FILE,0,.DA)
-        ;I FILE="T",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)>0 D
-        ;.S STS="" F  S STS=$O(@GBL@(DA(2),20,DA(1),5,"B",STS)) Q:STS=""  S DELSTS(STS)=""
-        ;display the current status 
-        D DISPLAY(GBL,UPDATE,.WILD,DELALL)
-        ;do inital prompt
-        D ADDDEL($G(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL)
-        Q
-        ;
-ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL)    ;
-        I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES")
-        I "ADDASQ"'[ANS Q
-        I ANS="A",WILD=1 D
-        .W !,"Wildcard is already on the status list all possible statuses will be evaluated."
-        .W !,"To add a specific status please remove the wildcard first."
-        .S UPDATE=0 H 1
-        I ANS="A",WILD=0 D ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE)
-        I ANS="D" D DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL)
-        I ANS="S" S UPDATE="S"
-        I ANS="Q" S UPDATE="Q"
-        I UPDATE'="S",UPDATE'="Q" S DELALL=0 D ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL)
-        ; only update the new record if the action is Save
-        I UPDATE="S" D UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL)
-        Q
-        ;
-ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE)       ;
-        N ANS,STATUS,TERMIEN
-        ;Find what types of finding is in the term
-        I TYPE["PXRMD(811.5," D
-        .S TERMIEN=$P($G(TYPE),";")
-        .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 Q
-        .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
-        I TYPE=0 Q
-        ;find out what is in the taxonomy
-        I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"")
-        I TYPE[";" S TYPE=$P($G(TYPE),";",2)
-        I TYPE="PXD(811.2," D  G ADDEX
-        .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
-        .;I $G(TAXTYPE)="P" D DATA^PXRMSTA2(FILE,.DA,"PROB","",.STATUS)
-        .;I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS)
-        ; handle drug finding items
-        I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D  G ADDEX
-        .D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
-        .D DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS)
-        ;radiology and orderable item finding item
-        D DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS)
-ADDEX   ;
-        I '$D(STATUS) S UPDATE=0 Q
-        S STAT="" F  S STAT=$O(STATUS(STAT)) Q:STAT=""!(WILD)=1  D
-        .I STAT["*" S WILD=1 Q
-        .S CSTATUS(STAT)=""
-        I WILD=1 K CSTATUS S CSTATUS("*")=""
-        S UPDATE=1 D DISPLAY(GBL,UPDATE,.WILD,0)
-        Q
-        ;
-DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA)  ;
-        N ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN
-        S FILE=""
-        I TYPE["PXRMD(811.5," D
-        .S TERMIEN=$P($G(TYPE),";")
-        .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 S STATUS="" Q
-        .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
-        I TYPE=0 Q
-        I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"")
-        I TYPE[";" S TYPE=$P($G(TYPE),";",2)
-        I TYPE="PXD(811.2," D
-        .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") S FILE=70
-        .;I $G(TAXTYPE)="P" S FILE=9000011
-        I FILE="",TYPE="ORD(101.43," S FILE=100
-        I FILE="",TYPE="RAMIS(71," S FILE=70
-        I FILE="",TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D
-        .N DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE
-        .D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
-        .I $D(RXTYPE("O")) D DEFAULT^PXRMSTAT(52,.STATUSO) D
-        ..F IND=1:1:STATUSO(0) S DSTATUS(STATUSO(IND))=""
-        .I $D(RXTYPE("I")) D DEFAULT^PXRMSTAT(55,.STATUSI) D
-        ..F IND=1:1:STATUSI(0) S DSTATUS(STATUSI(IND))=""
-        .I $D(RXTYPE("N")) D DEFAULT^PXRMSTAT("55NVA",.STATUSN) D
-        ..F IND=1:1:STATUSN(0) S DSTATUS(STATUSN(IND))=""
-        .S NAME="",IND=0 F  S NAME=$O(DSTATUS(NAME)) Q:NAME=""  D
-        ..S IND=IND+1 S STATUS(IND)=NAME
-        .S STATUS(0)=IND
-        I '$D(STATUS) D DEFAULT^PXRMSTAT(FILE,.STATUS)
-        F IND=1:1:STATUS(0) Q:$D(MSG)>0  D
-        .I DELETE=1 S CSTATUS(STATUS(IND))="" Q
-        .I $D(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND))) Q
-        .I RFILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
-        .I RFILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
-        .D UPDATE^DIE("","FDA","","MSG")
-        I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
-        Q
-        ;
-DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL)     ;
-        N ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y
-        S CNT=0,NAME="" F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""  D
-        .S CNT=CNT+1 S TMPARR(CNT)=CNT_" - "_NAME,TMP(CNT)=NAME
-        S DIR(0)="LO^1:"_CNT_""
-        M DIR("A")=TMPARR
-        S DIR("A")="Select which status to be deleted"
-        ;S DIR("?")=HELP
-        D ^DIR
-        I $D(DTOUT)!($D(DUOUT))!($G(Y)="") Q
-        S CNT=0 F X=1:1:$L(Y(0)) D
-        .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT) S NAME=TMP(NUM) K CSTATUS(NAME) I NAME["*" S WILD=0
-        S UPDATE=1
-        I FILE="T",$D(CSTATUS)'>0 S DELALL=1
-        ;.S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," 
-        ;D CLEAR(GBL,FILE,.DA)
-        ;I $D(CSTATUS)'>0 S DA=0 F  S DA=$O(^PXRMD(811.5,DA(2),20,DA(1),5,DA)) Q:DA'>0  D ^DIK
-        ;I '$D(CSTATUS) D CLEAR(GBL,FILE,.DA) D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA)
-        ;I '$D(CSTATUS),FILE="D" D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA)
-        D DISPLAY(GBL,UPDATE,.WILD,DELALL)
-        Q
-        ;
-DISPLAY(GBL,UPDATE,WILD,DELALL) ;
-        ;display statuses defined in the 5 node or display statuses if CStatus
-        ;array has been loaded
-        N NAME
-        S NAME=""
-        I ((UPDATE=1)&(DELALL=1))!(($D(CSTATUS)'>0)&(UPDATE=0)&(GBL["811.5")&('$D(@GBL@(DA(2),20,DA(1),5)))) W !!,"No statuses defined for this finding item" W ! Q 
-        W !!,"Statuses already defined for this finding item:"
-        ;I $D(CSTATUS)'>0,UPDATE=1 D 
-        ;.F  S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME=""  D
-        ;..S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
-        I $D(CSTATUS)'>0,UPDATE=0 D 
-        .F  S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME=""  D
-        ..I NAME["*" S WILD=1
-        ..W !,NAME S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
-        I UPDATE=1 F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""  W !,NAME I NAME["*" S WILD=1
-        W !
-        Q
-        ;
-        ;
-UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL)   ;
-        N FDA,MSG,NAME
-        I UPDATE="S" S UPDATE=1
-        I UPDATE=0,$D(CSTATUS) G EXIT
-        D CLEAR(GBL,FILE,.DA)
-        I $D(CSTATUS)'>0 S UPDATE=0,DELALL=0 G EXIT
-        I $D(CSTATUS)'>0 S UPDATE=1,DELALL=1 G EXIT
-        S NAME="" F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""!($D(MSG)>0)  D
-        .I FILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
-        .I FILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
-        .D UPDATE^DIE("","FDA","","MSG")
-        I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
-EXIT    ;
-        Q
-        ;
-PROMPT(STR)     ;
-        N DIR,HTEXT
-        S HTEXT(1)="Select 'A' to add a status to the current status list.\\Select 'D' to"
-        S HTEXT(2)="delete a status from the list.\\Select 'S' to save your changes and quit. "
-        S HTEXT(3)="\\Select 'Q' to quit without saving your changes."
-        S DIR(0)=STR
-        S DIR("B")="S"
-        S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help."
-        S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
-        D ^DIR
-        I $G(Y)="" S Y=U
-        Q Y
-        ;
-ASK(STR,HTEXT)  ;
-        N DIR,HTEXT
-        I '$D(HTEXT) D
-        .S HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit"
-        S DIR(0)="YA0"
-        S DIR("A")=STR
-        S DIR("B")="N"
-        S DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help."
-        S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
-        D ^DIR
-        Q Y
-        ;
-TAXTYPE(TERMIEN,HELP)   ;
-        ;use to determine the Rx type of the term and the type of taxonomy
-        N ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE
-        S (BOTH,PL,RAD,RESULT)=0
-        S IEN=0 F  S IEN=$O(^PXRMD(811.5,TERMIEN,20,IEN)) Q:+IEN'>0  D
-        .S TAXNODE=$G(^PXRMD(811.5,TERMIEN,20,IEN,0))
-        .S ARRAY($P($P($G(TAXNODE),U),";"))=""
-        I $D(ARRAY)>0 S IEN=0 F  S IEN=$O(ARRAY(IEN)) Q:IEN'>0  D
-        .S TYPE=$$TAXNODE(IEN,$G(HELP))
-        .I TYPE="R" S RAD=1
-        .I TYPE="P" S PL=1
-        .I TYPE="B" S BOTH=1
-        I RAD=1,PL=1 S RESULT="B" Q
-        I RAD=1,PL=0,BOTH=0 S RESULT="R"
-        I RAD=0,PL=1,BOTH=0 S RESULT="P"
-        Q RESULT
-        ;
-TAXNODE(TAXIEN,HELP)    ;
-        ;use to determine the type of taxonomy
-        N TAXNODE,ICD,CPT,ARRAY,RAD,PL,BOTH,RADM,PLM,RESULT
-        S (BOTH,PL,PLM,RAD,RADM,RESULT)=0
-        D CHECK^PXRMBXTL(TAXIEN,"")
-        I $D(^PXD(811.3,TAXIEN,71,"RCPTP"))>0 S RAD=1
-        I $D(^PXD(811.3,TAXIEN,"PDS",9000011))>0 S PL=1
-        I RAD=1,PL=1 S RESULT="B"
-        I RAD=1,PL=0 S RESULT="R"
-        I RAD=0,PL=1 S RESULT="P"
-        Q RESULT
-        ;
-        ;
-TERMSTAT(TIEN)  ;
-        N CNT,FIEN,NODE
-        S (CNT,FIEN)=0
-        S TYPE=0 F  S FIEN=$O(^PXRMD(811.5,TIEN,20,FIEN)) Q:+FIEN=0!(CNT=1)  D
-        . S NODE=$G(^PXRMD(811.5,TIEN,20,FIEN,0)),TYPE=$P(NODE,U),CNT=CNT+1
-        Q TYPE
-        ;
-WARN    ;
-        ;If the whole entry is being deleted don't give the warning.
-        I $G(PXRMDEFD) Q
-        I $G(PXRMTMD) Q
-        ;Do not execute as part of exchange.
-        I $G(PXRMEXCH) Q
-        N TEXT
-        S TEXT(1)=""
-        S TEXT(2)="Since you changed the value of Rx Type, you should review the status list"
-        S TEXT(3)="for the finding to make sure it is still appropriate."
-        S TEXT(4)=""
-        D EN^DDIOL(.TEXT)
-        Q
-        ;
-        ;
+PXRMSTA1 ; SLC/AGP - Routines for building status list. ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;This routine and PXRMSTA2 will allow users to select the
+ ;approriate status for Orders, Medication, Taxonomy, Problem List,
+ ;and Radiology Procedure findings items.
+ ;
+CLEAR(GBL,FILE,DA) ;
+ N IEN,NODE,DIK,TEMP
+ I FILE="D" S DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5,"
+ I FILE="T" S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5,"
+ S DA=0 F  S DA=$O(@GBL@(DA(2),20,DA(1),5,DA)) Q:DA'>0  S TEMP(DA)=""
+ S DA=0 F  S DA=$O(TEMP(DA)) Q:DA'>0  D ^DIK
+ Q
+ ;
+STATUS(DA,FILE) ;
+ N ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE
+ N RXTYPE,TAXNODE,TERMTYPE,Y
+ N CSTATUS,UPDATE,HTEXT,OSTAUS,WILD
+ S DA(2)=DA(1),DA(1)=DA,DA="",UPDATE=0,DELALL=0
+ I FILE="D" S GBL="^PXD(811.9)"
+ I FILE="T" S GBL="^PXRMD(811.5)"
+ S NODE=$G(@GBL@(DA(2),20,DA(1),0))
+ S TYPE=$P($G(@GBL@(DA(2),20,DA(1),0)),U)
+ S WILD=0
+ ;check for current defined statuses if none set the default values
+ I FILE="D",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0 D DEFAULT(GBL,TYPE,NODE,FILE,0,.DA)
+ ;I FILE="T",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)>0 D
+ ;.S STS="" F  S STS=$O(@GBL@(DA(2),20,DA(1),5,"B",STS)) Q:STS=""  S DELSTS(STS)=""
+ ;display the current status 
+ D DISPLAY(GBL,UPDATE,.WILD,DELALL)
+ ;do inital prompt
+ D ADDDEL($G(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL)
+ Q
+ ;
+ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) ;
+ I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES","S")
+ I "ADDASQ"'[ANS Q
+ I ANS="A",WILD=1 D
+ .W !,"Wildcard is already on the status list all possible statuses will be evaluated."
+ .W !,"To add a specific status please remove the wildcard first."
+ .S UPDATE=0 H 1
+ I ANS="A",WILD=0 D ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE)
+ I ANS="D" D DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL)
+ I ANS="S" S UPDATE="S"
+ I ANS="Q" S UPDATE="Q"
+ I UPDATE'="S",UPDATE'="Q" S DELALL=0 D ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL)
+ ; only update the new record if the action is Save
+ I UPDATE="S" D UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL)
+ Q
+ ;
+ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ;
+ N ANS,STATUS,TERMIEN
+ ;Find what types of finding is in the term
+ I TYPE["PXRMD(811.5," D
+ .S TERMIEN=$P($G(TYPE),";")
+ .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 Q
+ .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
+ I TYPE=0 Q
+ ;find out what is in the taxonomy
+ I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"")
+ I TYPE[";" S TYPE=$P($G(TYPE),";",2)
+ I TYPE="PXD(811.2," D  G ADDEX
+ .I $G(TAXTYPE)="R" D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
+ .;I $G(TAXTYPE)="P" D DATA^PXRMSTA2(FILE,.DA,"PROB","",.STATUS)
+ .I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS)
+ ; handle drug finding items
+ I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D  G ADDEX
+ .D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
+ .D DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS)
+ ;radiology and orderable item finding item
+ D DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS)
+ADDEX ;
+ I '$D(STATUS) S UPDATE=0 Q
+ S STAT="" F  S STAT=$O(STATUS(STAT)) Q:STAT=""!(WILD)=1  D
+ .I STAT["*" S WILD=1 Q
+ .S CSTATUS(STAT)=""
+ I WILD=1 K CSTATUS S CSTATUS("*")=""
+ S UPDATE=1 D DISPLAY(GBL,UPDATE,.WILD,0)
+ Q
+ ;
+DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) ;
+ N ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN
+ S FILE=""
+ I TYPE["PXRMD(811.5," D
+ .S TERMIEN=$P($G(TYPE),";")
+ .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 S STATUS="" Q
+ .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
+ I TYPE=0 Q
+ I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"")
+ I TYPE[";" S TYPE=$P($G(TYPE),";",2)
+ I TYPE="PXD(811.2," D
+ .I $G(TAXTYPE)="R" S FILE=70
+ .I $G(TAXTYPE)="P" S FILE=9000011
+ I FILE="",TYPE="ORD(101.43," S FILE=100
+ I FILE="",TYPE="RAMIS(71," S FILE=70
+ I FILE="",TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D
+ .N DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE
+ .D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
+ .I $D(RXTYPE("O")) D DEFAULT^PXRMSTAT(52,.STATUSO) D
+ ..F IND=1:1:STATUSO(0) S DSTATUS(STATUSO(IND))=""
+ .I $D(RXTYPE("I")) D DEFAULT^PXRMSTAT(55,.STATUSI) D
+ ..F IND=1:1:STATUSI(0) S DSTATUS(STATUSI(IND))=""
+ .I $D(RXTYPE("N")) D DEFAULT^PXRMSTAT("55NVA",.STATUSN) D
+ ..F IND=1:1:STATUSN(0) S DSTATUS(STATUSN(IND))=""
+ .S NAME="",IND=0 F  S NAME=$O(DSTATUS(NAME)) Q:NAME=""  D
+ ..S IND=IND+1 S STATUS(IND)=NAME
+ .S STATUS(0)=IND
+ I '$D(STATUS) D DEFAULT^PXRMSTAT(FILE,.STATUS)
+ F IND=1:1:STATUS(0) Q:$D(MSG)>0  D
+ .I DELETE=1 S CSTATUS(STATUS(IND))="" Q
+ .I $D(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND))) Q
+ .I RFILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
+ .I RFILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
+ .D UPDATE^DIE("","FDA","","MSG")
+ I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
+ Q
+ ;
+DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) ;
+ N ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y
+ S CNT=0,NAME="" F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""  D
+ .S CNT=CNT+1 S TMPARR(CNT)=CNT_" - "_NAME,TMP(CNT)=NAME
+ S DIR(0)="LO^1:"_CNT_""
+ M DIR("A")=TMPARR
+ S DIR("A")="Select which status to be deleted"
+ ;S DIR("?")=HELP
+ D ^DIR
+ I $D(DTOUT)!($D(DUOUT))!($G(Y)="") Q
+ S CNT=0 F X=1:1:$L(Y(0)) D
+ .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT) S NAME=TMP(NUM) K CSTATUS(NAME) I NAME["*" S WILD=0
+ S UPDATE=1
+ I FILE="T",$D(CSTATUS)'>0 S DELALL=1
+ ;.S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," 
+ ;D CLEAR(GBL,FILE,.DA)
+ ;I $D(CSTATUS)'>0 S DA=0 F  S DA=$O(^PXRMD(811.5,DA(2),20,DA(1),5,DA)) Q:DA'>0  D ^DIK
+ ;I '$D(CSTATUS) D CLEAR(GBL,FILE,.DA) D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA)
+ ;I '$D(CSTATUS),FILE="D" D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA)
+ D DISPLAY(GBL,UPDATE,.WILD,DELALL)
+ Q
+ ;
+DISPLAY(GBL,UPDATE,WILD,DELALL) ;
+ ;display statuses defined in the 5 node or display statuses if CStatus
+ ;array has been loaded
+ N NAME
+ S NAME=""
+ I ((UPDATE=1)&(DELALL=1))!(($D(CSTATUS)'>0)&(UPDATE=0)&(GBL["811.5")&('$D(@GBL@(DA(2),20,DA(1),5)))) W !!,"No statuses defined for this finding item" W ! Q 
+ W !!,"Statuses already defined for this finding item:"
+ ;I $D(CSTATUS)'>0,UPDATE=1 D 
+ ;.F  S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME=""  D
+ ;..S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
+ I $D(CSTATUS)'>0,UPDATE=0 D 
+ .F  S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME=""  D
+ ..I NAME["*" S WILD=1
+ ..W !,NAME S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
+ I UPDATE=1 F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""  W !,NAME I NAME["*" S WILD=1
+ W !
+ Q
+ ;
+ ;
+UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) ;
+ N FDA,MSG,NAME
+ I UPDATE="S" S UPDATE=1
+ I UPDATE=0,$D(CSTATUS) G EXIT
+ D CLEAR(GBL,FILE,.DA)
+ I $D(CSTATUS)'>0 S UPDATE=0,DELALL=0 G EXIT
+ I $D(CSTATUS)'>0 S UPDATE=1,DELALL=1 G EXIT
+ S NAME="" F  S NAME=$O(CSTATUS(NAME)) Q:NAME=""!($D(MSG)>0)  D
+ .I FILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
+ .I FILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
+ .D UPDATE^DIE("","FDA","","MSG")
+ I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
+EXIT ;
+ Q
+ ;
+PROMPT(STR,DEFAULT) ;
+ N DIR,HTEXT
+ S HTEXT(1)="Select 'A' to add a status to the current status list. Select 'D' to "
+ S HTEXT(2)="delete a status from the list. Select 'S' to save your changes and quit. "
+ S HTEXT(3)="Select 'Q' to quit without saving your changes."
+ S DIR(0)=STR
+ S DIR("B")="S"
+ S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help."
+ S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
+ D ^DIR
+ I $G(Y)="" S Y=U
+ Q Y
+ ;
+ASK(STR,HTEXT) ;
+ N DIR,HTEXT
+ I '$D(HTEXT) D
+ .S HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit"
+ S DIR(0)="YA0"
+ S DIR("A")=STR
+ S DIR("B")="N"
+ S DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help."
+ S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
+ D ^DIR
+ Q Y
+ ;
+TAXTYPE(TERMIEN,HELP) ;
+ ;use to determine the Rx type of the term and the type of taxonomy
+ N ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE
+ S (BOTH,PL,RAD,RESULT)=0
+ S IEN=0 F  S IEN=$O(^PXRMD(811.5,TERMIEN,20,IEN)) Q:+IEN'>0  D
+ .S TAXNODE=$G(^PXRMD(811.5,TERMIEN,20,IEN,0))
+ .S ARRAY($P($P($G(TAXNODE),U),";"))=""
+ I $D(ARRAY)>0 S IEN=0 F  S IEN=$O(ARRAY(IEN)) Q:IEN'>0  D
+ .S TYPE=$$TAXNODE(IEN,$G(HELP))
+ .I TYPE="R" S RAD=1
+ .I TYPE="P" S PL=1
+ .I TYPE="B" S BOTH=1
+ I RAD=1,PL=1 S RESULT="B" Q
+ I RAD=1,PL=0,BOTH=0 S RESULT="R"
+ I RAD=0,PL=1,BOTH=0 S RESULT="P"
+ Q RESULT
+ ;
+TAXNODE(TAXIEN,HELP) ;
+ ;use to determine the type of taxonomy
+ N TAXNODE,ICD,CPT,ARRAY,RAD,PL,BOTH,RADM,PLM,RESULT
+ S (BOTH,PL,PLM,RAD,RADM,RESULT)=0
+ D CHECK^PXRMBXTL(TAXIEN,"")
+ I $D(^PXD(811.3,TAXIEN,71,"RCPTP"))>0 S RAD=1
+ I $D(^PXD(811.3,TAXIEN,"PDS",9000011))>0 S PL=1
+ I RAD=1,PL=1 S RESULT="B"
+ I RAD=1,PL=0 S RESULT="R"
+ I RAD=0,PL=1 S RESULT="P"
+ Q RESULT
+ ;
+ ;
+TERMSTAT(TIEN) ;
+ N CNT,FIEN,NODE
+ S (CNT,FIEN)=0
+ S TYPE=0 F  S FIEN=$O(^PXRMD(811.5,TIEN,20,FIEN)) Q:+FIEN=0!(CNT=1)  D
+ . S NODE=$G(^PXRMD(811.5,TIEN,20,FIEN,0)),TYPE=$P(NODE,U),CNT=CNT+1
+ Q TYPE
+ ;
+WARN ;
+ ;If the whole entry is being deleted don't give the warning.
+ I $G(PXRMDEFD) Q
+ I $G(PXRMTMD) Q
+ ;Do not execute as part of exchange.
+ I $G(PXRMEXCH) Q
+ N TEXT
+ S TEXT(1)=""
+ S TEXT(2)="Since you changed the value of Rx Type, you should review the status list"
+ S TEXT(3)="for the finding to make sure it is still appropriate."
+ S TEXT(4)=""
+ D EN^DDIOL(.TEXT)
+ Q
+ ;
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m

@@ -1 @@
-PXRMSTA2        ; SLC/AGP - Routines for building status list. ;03/27/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-DATA(FILE,DA,TYPE,RXTYPE,STATUS)        ;
-        ; this sub routine get the list of statuses from the apporiate global
-        ;
-        N ARRAY,ARRAY1,CNT,CODE,DEF,OUTPUT,SARRAY,STAT
-LOOP    ;
-        ;get build status list into a local array from each pharmacy type of
-        ;finding item
-        I TYPE="DRUG" D
-        .I $D(RXTYPE("I"))>0 D
-        . . D STATUS^PSS55MIS(55.06,28,"SARRAY")
-        . . ;D FIELD^DID(55.06,28,"","POINTER","SARRAY")
-        . . D ARRAYFOR(.SARRAY,.ARRAY,"I") K CODE
-        . . D STATUS^PSS55MIS(55.01,100,"SARRAY")
-        . . ;D FIELD^DID(55.01,100,"","POINTER","SARRAY")
-        . . D ARRAYFOR(.SARRAY,.ARRAY1,"I") K CODE
-        . . D COMPARE(.ARRAY,.ARRAY1,"I",.OUTPUT)
-        . I $D(RXTYPE("O"))>0 D
-        . . K ARRAY,ARRAY1,CODE
-        . . D STATUS^PSODI(52,100,"SARRAY")
-        . . ;D FIELD^DID(52,100,"","POINTER","SARRAY")
-        . . D ARRAYFOR(.SARRAY,.ARRAY,"O") K CODE
-        . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT)
-        . . E  M OUTPUT=ARRAY
-        . I $D(RXTYPE("N"))>0 D
-        . . K ARRAY,ARRAY1,CODE
-        . . D STATUS^PSS55MIS(55.05,5,"SARRAY")
-        . . ;D FIELD^DID(55.05,5,"","POINTER","SARRAY")
-        . . S SARRAY("POINTER")=SARRAY("POINTER")_"0:ACTIVE;"
-        . . D ARRAYFOR(.SARRAY,.ARRAY,"N") K CODE
-        . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT)
-        . . E  M OUTPUT=ARRAY
-        ;
-        I TYPE="PROB" S OUTPUT("ACTIVE")="ACTIVE",OUTPUT("INACTIVE")="INACTIVE"
-        I TYPE="ORD(101.43," D
-        . S CNT=0,STAT="" F  S STAT=$O(^ORD(100.01,"B",STAT)) Q:STAT=""  D
-        . . S CNT=CNT+1 S OUTPUT(STAT)=STAT
-        I TYPE="RAMIS(71,"!(TYPE="TAX") D
-        . S TYPE="RAMIS(71,"
-        . S CNT=0,STAT="" F  S STAT=$O(^RA(72,"B",STAT)) Q:STAT=""  D
-        . . S CNT=CNT+1 S OUTPUT(STAT)=STAT
-        .;I TYPE'="TAX" Q
-        .;I '$D(OUTPUT("ACTIVE")) S OUTPUT("ACTIVE")="ACTIVE"
-        .;I '$D(OUTPUT("INACTIVE")) S OUTPUT("INACTIVE")="INACTIVE"
-        D SELECT(.OUTPUT,FILE,TYPE,.STATUS,.DA)
-        ;
-        Q
-        ;
-COMPARE(ARRAY,ARRAY1,TYPE,OUTPUT)       ;
-        ; this sub routine is use to combine the InPatient and 
-        ; Both Pharmacy type into one array
-        N ARY,CNT,COMP,NODE
-        K OUTPUT
-        S COMP=""
-        ;
-        ;inpatient pharmacy list is built from two seperated fields in file #55
-        ;this is used to combined the two fields into one array
-        I $G(TYPE)="I" D
-        . F  S COMP=$O(ARRAY(COMP)) Q:COMP=""  D
-        . . S OUTPUT(COMP)=ARRAY(COMP)
-        . S (COMP)="" F  S COMP=$O(ARRAY1(COMP)) Q:COMP=""  D
-        . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=ARRAY1(COMP)
-        ;
-        ;this section is uses to combine the different RX Types into one array
-        I $G(TYPE)'="I" D
-        . F  S COMP=$O(ARRAY(COMP)) Q:COMP=""  D
-        . . S NODE=$G(ARRAY(COMP))
-        . . S OUTPUT(COMP)=NODE
-        . S COMP="" F  S COMP=$O(ARRAY1(COMP)) Q:COMP=""  D
-        . . S NODE=$G(ARRAY1(COMP))
-        . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=NODE Q
-        . . I $D(OUTPUT(COMP)) S $P(OUTPUT(COMP),U,2)=$P(OUTPUT(COMP),U,2)_$P(NODE,U,2)
-        Q
-        ;
-ARRAYFOR(ARRAY,OUTPUT,DEF)      ;
-        ;this sub routine is use to format the array data into a standard 
-        ;format
-        ;
-        N CNT,COMP,PIECE,STR,TYPE
-        S PIECE=0
-        ;
-        ;determine the number of pieces minus one in the string
-        F CNT=1:1:$L(ARRAY("POINTER")) I $E(ARRAY("POINTER"),CNT)=";" S PIECE=PIECE+1 I PIECE>0 D
-        . S STR=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2)
-        . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=STR_U_$G(DEF)
-        ;
-        ;add last piece in the string to the array
-        I PIECE>0 S PIECE=PIECE+1 D
-        . I $P($G(ARRAY("POINTER")),";",PIECE)'="" D
-        . . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2)_U_$G(DEF)
-        Q
-        ;
-SELECT(ARRAY,FILE,TYPE,STATUS,DA)       ;
-        ; this sub routine is use to sort through the formated array and 
-        ; set up the DIR call
-        ;
-        N CHECK,CNT,CNT1,DIR,DUOUT,DTOUT,EMPTY,EXTR
-        N HELP,LENGTH,NODE,STAT,STR,TEXT,TMP,X,Y
-        N TMPARR,NUM
-DISPLAY ;
-        I TYPE="DRUG" S TEXT="Select a Medication Status or enter '^' to Quit",HELP="Select a status from the Medication Status list or '^' to Quit"
-        I TYPE="ORD(101.43," S TEXT="Select a Order Status from or enter '^' to Quit",HELP="Select a Order Status from the status list or '^' to Quit"
-        I TYPE="RAMIS(71," S TEXT="Select a Radiology Procedure Status or enter '^' to Quit",HELP="Select a Radiology Procedure Status from the status list or '^' to Quit"
-        ;I TYPE="TAX" S TEXT="Select a Taxonomy Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit"
-        ;I TYPE="PROB" S TEXT="Select a Problem Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit"
-        ;
-        S CNT=0,CNT1=0,STAT=""
-        ;if text is not entered into the prompt or no match is found display
-        ;entire list of statuses for this finding item
-        ;
-        ;Add wildcard character
-        S CNT=CNT+1,CNT1=CNT1+1,TMP(CNT)=CNT_" - * (WildCard)",TMPARR(CNT)="*"
-        ;Add status from file to the selectable list
-        F  S STAT=$O(ARRAY(STAT)) Q:STAT=""  D
-        . S NODE=$G(ARRAY(STAT))
-        . S STR=$P(NODE,U)
-        . S CNT=CNT+1,CNT1=CNT1+1
-        . I TYPE="DRUG" S TMP(CNT)=CNT_" - "_STR_"("_$P(NODE,U,2)_")",TMPARR(CNT)=STR
-        . E  S TMP(CNT)=CNT_" - "_STR,TMPARR(CNT)=STR
-        ;
-        S DIR(0)="LO^1:"_CNT_""
-        M DIR("A")=TMP
-        S DIR("A")=TEXT
-        S DIR("?")=HELP
-        D ^DIR
-        I $D(DTOUT)!($D(DUOUT))!($G(Y)="") K STATUS Q
-        S CNT=0 F X=1:1:$L(Y(0)) D
-        .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT),STATUS(TMPARR(NUM))=""
-        ;S STATUS=Y(0)
-        ;I STATUS="WildCard" S STATUS="*"
-        Q
-        ;
+PXRMSTA2 ; SLC/AGP - Routines for building status list. ;9/26/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+DATA(FILE,DA,TYPE,RXTYPE,STATUS) ;
+ ; this sub routine get the list of statuses from the apporiate global
+ ;
+ N ARRAY,ARRAY1,CNT,CODE,DEF,OUTPUT,SARRAY,STAT
+LOOP ;
+ ;get build status list into a local array from each pharmacy type of
+ ;finding item
+ I TYPE="DRUG" D
+ .I $D(RXTYPE("I"))>0 D
+ . . D FIELD^DID(55.06,28,"","POINTER","SARRAY")
+ . . D ARRAYFOR(.SARRAY,.ARRAY,"I") K CODE
+ . . D FIELD^DID(55.01,100,"","POINTER","SARRAY")
+ . . D ARRAYFOR(.SARRAY,.ARRAY1,"I") K CODE
+ . . D COMPARE(.ARRAY,.ARRAY1,"I",.OUTPUT)
+ . I $D(RXTYPE("O"))>0 D
+ . . K ARRAY,ARRAY1,CODE
+ . . D FIELD^DID(52,100,"","POINTER","SARRAY")
+ . . D ARRAYFOR(.SARRAY,.ARRAY,"O") K CODE
+ . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT)
+ . . E  M OUTPUT=ARRAY
+ . I $D(RXTYPE("N"))>0 D
+ . . K ARRAY,ARRAY1,CODE
+ . . D FIELD^DID(55.05,5,"","POINTER","SARRAY")
+ . . S SARRAY("POINTER")=SARRAY("POINTER")_"0:ACTIVE;"
+ . . D ARRAYFOR(.SARRAY,.ARRAY,"N") K CODE
+ . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT)
+ . . E  M OUTPUT=ARRAY
+ ;
+ I TYPE="PROB" S OUTPUT("ACTIVE")="ACTIVE",OUTPUT("INACTIVE")="INACTIVE"
+ I TYPE="ORD(101.43," D
+ . S CNT=0,STAT="" F  S STAT=$O(^ORD(100.01,"B",STAT)) Q:STAT=""  D
+ . . S CNT=CNT+1 S OUTPUT(STAT)=STAT
+ I TYPE="RAMIS(71,"!(TYPE="TAX") D
+ . S TYPE="RAMIS(71,"
+ . S CNT=0,STAT="" F  S STAT=$O(^RA(72,"B",STAT)) Q:STAT=""  D
+ . . S CNT=CNT+1 S OUTPUT(STAT)=STAT
+ .;I TYPE'="TAX" Q
+ .;I '$D(OUTPUT("ACTIVE")) S OUTPUT("ACTIVE")="ACTIVE"
+ .;I '$D(OUTPUT("INACTIVE")) S OUTPUT("INACTIVE")="INACTIVE"
+ D SELECT(.OUTPUT,FILE,TYPE,.STATUS,.DA)
+ ;
+ Q
+ ;
+COMPARE(ARRAY,ARRAY1,TYPE,OUTPUT) ;
+ ; this sub routine is use to combine the InPatient and 
+ ; Both Pharmacy type into one array
+ N ARY,CNT,COMP,NODE
+ K OUTPUT
+ S COMP=""
+ ;
+ ;inpatient pharmacy list is built from two seperated fields in file #55
+ ;this is used to combined the two fields into one array
+ I $G(TYPE)="I" D
+ . F  S COMP=$O(ARRAY(COMP)) Q:COMP=""  D
+ . . S OUTPUT(COMP)=ARRAY(COMP)
+ . S (COMP)="" F  S COMP=$O(ARRAY1(COMP)) Q:COMP=""  D
+ . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=ARRAY1(COMP)
+ ;
+ ;this section is uses to combine the different RX Types into one array
+ I $G(TYPE)'="I" D
+ . F  S COMP=$O(ARRAY(COMP)) Q:COMP=""  D
+ . . S NODE=$G(ARRAY(COMP))
+ . . S OUTPUT(COMP)=NODE
+ . S COMP="" F  S COMP=$O(ARRAY1(COMP)) Q:COMP=""  D
+ . . S NODE=$G(ARRAY1(COMP))
+ . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=NODE Q
+ . . I $D(OUTPUT(COMP)) S $P(OUTPUT(COMP),U,2)=$P(OUTPUT(COMP),U,2)_$P(NODE,U,2)
+ Q
+ ;
+ARRAYFOR(ARRAY,OUTPUT,DEF) ;
+ ;this sub routine is use to format that array data into a standard 
+ ;format
+ ;
+ N CNT,COMP,PIECE,STR,TYPE
+ S PIECE=0
+ ;
+ ;determine the number of pieces minus one in the string
+ F CNT=1:1:$L(ARRAY("POINTER")) I $E(ARRAY("POINTER"),CNT)=";" S PIECE=PIECE+1 I PIECE>0 D
+ . S STR=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2)
+ . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=STR_U_$G(DEF)
+ ;
+ ;add last piece in the string to the array
+ I PIECE>0 S PIECE=PIECE+1 D
+ . I $P($G(ARRAY("POINTER")),";",PIECE)'="" D
+ . . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2)_U_$G(DEF)
+ Q
+ ;
+SELECT(ARRAY,FILE,TYPE,STATUS,DA) ;
+ ; this sub routine is use to sort through the formated array and 
+ ; set up the DIR call
+ ;
+ N CHECK,CNT,CNT1,DIR,DUOUT,DTOUT,EMPTY,EXTR
+ N HELP,LENGTH,NODE,STAT,STR,TEXT,TMP,X,Y
+ N TMPARR,NUM
+DISPLAY ;
+ I TYPE="DRUG" S TEXT="Select a Medication Status or enter '^' to Quit",HELP="Select a status from the Medication Status list or '^' to Quit"
+ I TYPE="ORD(101.43," S TEXT="Select a Order Status from or enter '^' to Quit",HELP="Select a Order Status from the status list or '^' to Quit"
+ I TYPE="RAMIS(71," S TEXT="Select a Radiology Procedure Status or enter '^' to Quit",HELP="Select a Radiology Procedure Status from the status list or '^' to Quit"
+ ;I TYPE="TAX" S TEXT="Select a Taxonomy Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit"
+ ;I TYPE="PROB" S TEXT="Select a Problem Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit"
+ ;
+ S CNT=0,CNT1=0,STAT=""
+ ;if text is not entered into the prompt or no match is found display
+ ;entire list of statuses for this finding item
+ ;
+ ;Add wildcard character
+ S CNT=CNT+1,CNT1=CNT1+1,TMP(CNT)=CNT_" - * (WildCard)",TMPARR(CNT)="*"
+ ;Add status from file to the selectable list
+ F  S STAT=$O(ARRAY(STAT)) Q:STAT=""  D
+ . S NODE=$G(ARRAY(STAT))
+ . S STR=$P(NODE,U)
+ . S CNT=CNT+1,CNT1=CNT1+1
+ . I TYPE="DRUG" S TMP(CNT)=CNT_" - "_STR_"("_$P(NODE,U,2)_")",TMPARR(CNT)=STR
+ . E  S TMP(CNT)=CNT_" - "_STR,TMPARR(CNT)=STR
+ ;
+ S DIR(0)="LO^1:"_CNT_""
+ M DIR("A")=TMP
+ S DIR("A")=TEXT
+ S DIR("?")=HELP
+ D ^DIR
+ I $D(DTOUT)!($D(DUOUT))!($G(Y)="") K STATUS Q
+ S CNT=0 F X=1:1:$L(Y(0)) D
+ .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT),STATUS(TMPARR(NUM))=""
+ ;S STATUS=Y(0)
+ ;I STATUS="WildCard" S STATUS="*"
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m

@@ -1 @@
-PXRMSXRM        ; SLC/PKR - Main driver for building indexes. ;11/23/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;==========================================
-ADDERROR(GLOBAL,IDEN,NERROR)    ;Add to the error list.
-        S NERROR=NERROR+1
-        S ^TMP("PXRMERROR",$J,NERROR,0)="GLOBAL: "_GLOBAL_" ENTRY: "_IDEN
-        Q
-        ;
-        ;==========================================
-ASKTASK()       ;See if this should be tasked.
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
-        S DIR(0)="YO"
-        S DIR("A")="Do you want this to be tasked"
-        S DIR("B")="Y"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q ""
-        I $D(DUOUT)!$D(DTOUT) Q ""
-        Q Y
-        ;
-        ;==========================================
-COMMSG(GLOBAL,START,END,NE,NERROR)      ;Send a MailMan message providing
-        ;notification that the indexing completed.
-        N XMSUB
-        K ^TMP("PXRMXMZ",$J)
-        S XMSUB="Index for global "_GLOBAL_" sucessfully built"
-        S ^TMP("PXRMXMZ",$J,1,0)="Build of Clinical Reminders index for global "_GLOBAL_" completed."
-        S ^TMP("PXRMXMZ",$J,2,0)="Build finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S ^TMP("PXRMXMZ",$J,3,0)=NE_" entries were created."
-        S ^TMP("PXRMXMZ",$J,4,0)=$$ETIME(START,END)
-        S ^TMP("PXRMXMZ",$J,5,0)=NERROR_" errors were encountered."
-        I NERROR>0 S ^TMP("PXRMXMZ",$J,6,0)="Another MailMan message will contain the error information."
-        D SEND^PXRMMSG(XMSUB)
-        Q
-        ;
-        ;==========================================
-DETIME(START,END)       ;Write out the elapsed time.
-        ;START and END are $H times.
-        N TEXT
-        S TEXT=$$ETIME(START,END)
-        D MES^XPDUTL(TEXT)
-        Q
-        ;
-        ;==========================================
-ERRMSG(NERROR,GLOBAL)   ;If there were errors send an error message.
-        N END,IND,MAXERR,NE,XMSUB
-        I NERROR=0 Q
-        ;Return the last MAXERR errors
-        S MAXERR=+$G(^PXRM(800,1,"MIERR"))
-        I MAXERR=0 S MAXERR=200
-        K ^TMP("PXRMXMZ",$J)
-        S END=$S(NERROR'>MAXERR:NERROR,1:MAXERR)
-        S NE=NERROR+1
-        F IND=1:1:END S NE=NE-1,^TMP("PXRMXMZ",$J,IND,0)=^TMP("PXRMERROR",$J,NE,0)
-        I END=MAXERR S ^TMP("PXRMXMZ",$J,MAXERR+1,0)="GLOBAL: "_GLOBAL_"- Maximum number of errors reached, will not report any more."
-        K ^TMP("PXRMERROR",$J)
-        S XMSUB="CLINICAL REMINDER INDEX BUILD ERROR(S) FOR GLOBAL "_GLOBAL
-        D SEND^PXRMMSG(XMSUB)
-        Q
-        ;
-        ;==========================================
-ETIME(START,END)        ;Calculate and format the elapsed time.
-        ;START and END are $H times.
-        N ETIME,TEXT
-        S ETIME=$$HDIFF^XLFDT(END,START,2)
-        I ETIME>90 D
-        . S ETIME=$$HDIFF^XLFDT(END,START,3)
-        . S TEXT="Elapsed time: "_ETIME
-        E  S TEXT="Elapsed time: "_ETIME_" secs"
-        Q TEXT
-        ;
-        ;==========================================
-INDEX   ;Driver for building the various indexes.
-        N GBL,LIST,ROUTINE,TASKIT
-        S ROUTINE(45)="INDEX^DGPTDDCR" ;DBIA #4521
-        S ROUTINE(52)="PSRX^PSOPXRMI"  ;DBIA #4522
-        S ROUTINE(55)="PSPA^PSSSXRD"   ;DBIA #4172
-        S ROUTINE(63)="LAB^LRPXSXRL"   ;DBIA #4247
-        S ROUTINE(70)="RAD^RAPXRM"     ;DBIA #3731
-        S ROUTINE(100)="INDEX^ORPXRM"  ;DBIA #4498
-        S ROUTINE(120.5)="VITALS^GMVPXRM"  ;DBIA #3647
-        S ROUTINE(601.2)="INDEX^YTPXRM" ;DBIA #4523
-        S ROUTINE(601.84)="INDEX^YTQPXRM" ;DBIA #5055
-        S ROUTINE(9000011)="INDEX^GMPLPXRM" ;DBIA #4516
-        S ROUTINE(9000010.07)="VPOV^PXPXRMI2" ;DBIA #4520
-        S ROUTINE(9000010.11)="VIMM^PXPXRMI1" ;DBIA #4519
-        S ROUTINE(9000010.12)="VSK^PXPXRMI2"  ;DBIA #4520
-        S ROUTINE(9000010.13)="VXAM^PXPXRMI2" ;DBIA #4520
-        S ROUTINE(9000010.16)="VPED^PXPXRMI2" ;DBIA #4520
-        S ROUTINE(9000010.18)="VCPT^PXPXRMI1" ;DBIA #4519
-        S ROUTINE(9000010.23)="VHF^PXPXRMI1"  ;DBIA #4519
-        ;Get the list
-        W !,"Which indexes do you want to (re)build?"
-        D SEL(.LIST,.GBL)
-        I LIST="" Q
-        ;See if this should be tasked.
-        S TASKIT=$$ASKTASK
-        I TASKIT="" Q
-        I TASKIT D
-        . W !,"Queue the Clinical Reminders index job."
-        . D TASKIT(LIST,.GBL,.ROUTINE)
-        E  D RUNNOW(LIST,.GBL,.ROUTINE)
-        Q
-        ;
-        ;==========================================
-RUNNOW(LIST,GBL,ROUTINE)        ;Run the routines now.
-        N IND,LI,NUM,RTN
-        S NUM=$L(LIST,",")-1
-        F IND=1:1:NUM D
-        . S LI=$P(LIST,",",IND)
-        . S RTN=ROUTINE(GBL(LI))
-        . D @RTN
-        Q
-        ;
-        ;==========================================
-SEL(LIST,GBL)   ;Select global list
-        N ALIST,DIR,DIROUT,DIRUT,DTOUT,DUOUT,INUM,X,Y
-        S INUM=1,ALIST(INUM)="  "_INUM_" - LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(INUM)=63
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - MENTAL HEALTH",GBL(INUM)=601.2
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - MENTAL HEALTH (MHA3)",GBL(INUM)=601.84
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - ORDER",GBL(INUM)=100
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PTF",GBL(INUM)=45
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PHARMACY PATIENT",GBL(INUM)=55
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PRESCRIPTION",GBL(INUM)=52
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PROBLEM LIST",GBL(INUM)=9000011
-        S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - RADIOLOGY",GBL(INUM)=70
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V CPT",GBL(INUM)=9000010.18
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V EXAM",GBL(INUM)=9000010.13
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V HEALTH FACTORS",GBL(INUM)=9000010.23
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V IMMUNIZATION",GBL(INUM)=9000010.11
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V PATIENT ED",GBL(INUM)=9000010.16
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V POV",GBL(INUM)=9000010.07
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V SKIN TEST",GBL(INUM)=9000010.12
-        S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - VITAL MEASUREMENT",GBL(INUM)=120.5
-        M DIR("A")=ALIST
-        S DIR("A")="Enter your list"
-        S DIR(0)="LO^1:"_INUM
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) S LIST="" Q
-        I $D(DUOUT)!$D(DTOUT) S LIST="" Q
-        S LIST=Y
-        Q
-        ;
-        ;==========================================
-TASKIT(LIST,GBL,ROUTINE)        ;Build the indexes as a tasked job.
-        N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
-        S MINDT=$$NOW^XLFDT
-        S DIR("A",1)="Enter the date and time you want the job to start."
-        S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
-        S DIR("A")="Start the task at: "
-        S DIR(0)="DAU"_U_MINDT_"::RSX"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        I $D(DUOUT)!$D(DTOUT) Q
-        S SDTIME=Y
-        ;Put the task into the queue.
-        K ZTSAVE
-        S ZTSAVE("LIST")=""
-        S ZTSAVE("GBL(")=""
-        S ZTSAVE("ROUTINE(")=""
-        S ZTRTN="TASKJOB^PXRMSXRM"
-        S ZTDESC="Clinical Reminders index build"
-        S ZTDTH=SDTIME
-        S ZTIO=""
-        D ^%ZTLOAD
-        W !,"Task number ",ZTSK," queued."
-        Q
-        ;
-        ;==========================================
-TASKJOB ;Execute as tasked job. LIST, GBL, and ROUTINE come through
-        ;ZTSAVE.
-        N IND,LI,NUM,RTN
-        S ZTREQ="@"
-        S ZTSTOP=0
-        S NUM=$L(LIST,",")-1
-        F IND=1:1:NUM D
-        .;Check to see if the task has had a stop request
-        . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
-        . S LI=$P(LIST,",",IND)
-        . S RTN=ROUTINE(GBL(LI))
-        . D @RTN
-        Q
-        ;
+PXRMSXRM ; SLC/PKR - Main driver for building indexes. ;12/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;==========================================
+ADDERROR(GLOBAL,IDEN,NERROR) ;Add to the error list.
+ S NERROR=NERROR+1
+ S ^TMP("PXRMERROR",$J,NERROR,0)="GLOBAL: "_GLOBAL_" ENTRY: "_IDEN
+ Q
+ ;
+ ;==========================================
+ASKTASK() ;See if this should be tasked.
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S DIR(0)="YO"
+ S DIR("A")="Do you want this to be tasked"
+ S DIR("B")="Y"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q ""
+ I $D(DUOUT)!$D(DTOUT) Q ""
+ Q Y
+ ;
+ ;==========================================
+COMMSG(GLOBAL,START,END,NE,NERROR) ;Send a MailMan message providing
+ ;notification that the indexing completed.
+ N XMSUB
+ K ^TMP("PXRMXMZ",$J)
+ S XMSUB="Index for global "_GLOBAL_" sucessfully built"
+ S ^TMP("PXRMXMZ",$J,1,0)="Build of Clinical Reminders index for global "_GLOBAL_" completed."
+ S ^TMP("PXRMXMZ",$J,2,0)="Build finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S ^TMP("PXRMXMZ",$J,3,0)=NE_" entries were created."
+ S ^TMP("PXRMXMZ",$J,4,0)=$$ETIME(START,END)
+ S ^TMP("PXRMXMZ",$J,5,0)=NERROR_" errors were encountered."
+ I NERROR>0 S ^TMP("PXRMXMZ",$J,6,0)="Another MailMan message will contain the error information."
+ D SEND^PXRMMSG(XMSUB)
+ Q
+ ;
+ ;==========================================
+DETIME(START,END) ;Write out the elapsed time.
+ ;START and END are $H times.
+ N TEXT
+ S TEXT=$$ETIME(START,END)
+ D MES^XPDUTL(TEXT)
+ Q
+ ;
+ ;==========================================
+ERRMSG(NERROR,GLOBAL) ;If there were errors send an error message.
+ N END,IND,MAXERR,NE,XMSUB
+ I NERROR=0 Q
+ ;Return the last MAXERR errors
+ S MAXERR=+$G(^PXRM(800,1,"MIERR"))
+ I MAXERR=0 S MAXERR=200
+ K ^TMP("PXRMXMZ",$J)
+ S END=$S(NERROR'>MAXERR:NERROR,1:MAXERR)
+ S NE=NERROR+1
+ F IND=1:1:END S NE=NE-1,^TMP("PXRMXMZ",$J,IND,0)=^TMP("PXRMERROR",$J,NE,0)
+ I END=MAXERR S ^TMP("PXRMXMZ",$J,MAXERR+1,0)="GLOBAL: "_GLOBAL_"- Maximum number of errors reached, will not report any more."
+ K ^TMP("PXRMERROR",$J)
+ S XMSUB="CLINICAL REMINDER INDEX BUILD ERROR(S) FOR GLOBAL "_GLOBAL
+ D SEND^PXRMMSG(XMSUB)
+ Q
+ ;
+ ;==========================================
+ETIME(START,END) ;Calculate and format the elapsed time.
+ ;START and END are $H times.
+ N ETIME,TEXT
+ S ETIME=$$HDIFF^XLFDT(END,START,2)
+ I ETIME>90 D
+ . S ETIME=$$HDIFF^XLFDT(END,START,3)
+ . S TEXT="Elapsed time: "_ETIME
+ E  S TEXT="Elapsed time: "_ETIME_" secs"
+ Q TEXT
+ ;
+ ;==========================================
+INDEX ;Driver for building the various indexes.
+ N GBL,LIST,ROUTINE,TASKIT
+ S ROUTINE(45)="INDEX^DGPTDDCR" ;DBIA #4521
+ S ROUTINE(52)="PSRX^PSOPXRMI"  ;DBIA #4522
+ S ROUTINE(55)="PSPA^PSSSXRD"   ;DBIA #4172
+ S ROUTINE(63)="LAB^LRPXSXRL"   ;DBIA #4247
+ S ROUTINE(70)="RAD^RAPXRM"     ;DBIA #3731
+ S ROUTINE(100)="INDEX^ORPXRM"  ;DBIA #4498
+ S ROUTINE(120.5)="VITALS^GMVPXRM"  ;DBIA #3647
+ S ROUTINE(601.2)="INDEX^YTPXRM" ;DBIA #4523
+ S ROUTINE(9000011)="INDEX^GMPLPXRM" ;DBIA #4516
+ S ROUTINE(9000010.07)="VPOV^PXPXRMI2" ;DBIA #4520
+ S ROUTINE(9000010.11)="VIMM^PXPXRMI1" ;DBIA #4519
+ S ROUTINE(9000010.12)="VSK^PXPXRMI2"  ;DBIA #4520
+ S ROUTINE(9000010.13)="VXAM^PXPXRMI2" ;DBIA #4520
+ S ROUTINE(9000010.16)="VPED^PXPXRMI2" ;DBIA #4520
+ S ROUTINE(9000010.18)="VCPT^PXPXRMI1" ;DBIA #4519
+ S ROUTINE(9000010.23)="VHF^PXPXRMI1"  ;DBIA #4519
+ ;Get the list
+ W !,"Which indexes do you want to (re)build?"
+ D SEL(.LIST,.GBL)
+ I LIST="" Q
+ ;See if this should be tasked.
+ S TASKIT=$$ASKTASK
+ I TASKIT="" Q
+ I TASKIT D
+ . W !,"Queue the Clinical Reminders index job."
+ . D TASKIT(LIST,.GBL,.ROUTINE)
+ E  D RUNNOW(LIST,.GBL,.ROUTINE)
+ Q
+ ;
+ ;==========================================
+RUNNOW(LIST,GBL,ROUTINE) ;Run the routines now.
+ N IND,LI,NUM,RTN
+ S NUM=$L(LIST,",")-1
+ F IND=1:1:NUM D
+ . S LI=$P(LIST,",",IND)
+ . S RTN=ROUTINE(GBL(LI))
+ . D @RTN
+ Q
+ ;
+ ;==========================================
+SEL(LIST,GBL) ;Select global list
+ N ALIST,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S ALIST(1)="  1 - LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
+ S ALIST(2)="  2 - MENTAL HEALTH",GBL(2)=601.2
+ S ALIST(3)="  3 - ORDER",GBL(3)=100
+ S ALIST(4)="  4 - PTF",GBL(4)=45
+ S ALIST(5)="  5 - PHARMACY PATIENT",GBL(5)=55
+ S ALIST(6)="  6 - PRESCRIPTION",GBL(6)=52
+ S ALIST(7)="  7 - PROBLEM LIST",GBL(7)=9000011
+ S ALIST(8)="  8 - RADIOLOGY",GBL(8)=70
+ S ALIST(9)="  9 - V CPT",GBL(9)=9000010.18
+ S ALIST(10)=" 10 - V EXAM",GBL(10)=9000010.13
+ S ALIST(11)=" 11 - V HEALTH FACTORS",GBL(11)=9000010.23
+ S ALIST(12)=" 12 - V IMMUNIZATION",GBL(12)=9000010.11
+ S ALIST(13)=" 13 - V PATIENT ED",GBL(13)=9000010.16
+ S ALIST(14)=" 14 - V POV",GBL(14)=9000010.07
+ S ALIST(15)=" 15 - V SKIN TEST",GBL(15)=9000010.12
+ S ALIST(16)=" 16 - VITAL MEASUREMENT",GBL(16)=120.5
+ M DIR("A")=ALIST
+ S DIR("A")="Enter your list"
+ S DIR(0)="LO^1:16"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) S LIST="" Q
+ I $D(DUOUT)!$D(DTOUT) S LIST="" Q
+ S LIST=Y
+ Q
+ ;
+ ;==========================================
+TASKIT(LIST,GBL,ROUTINE) ;Build the indexes as a tasked job.
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y
+ S MINDT=$$NOW^XLFDT
+ S DIR("A",1)="Enter the date and time you want the job to start."
+ S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
+ S DIR("A")="Start the task at: "
+ S DIR(0)="DAU"_U_MINDT_"::RSX"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ I $D(DUOUT)!$D(DTOUT) Q
+ S SDTIME=Y
+ ;Put the task into the queue.
+ K ZTSAVE
+ S ZTSAVE("LIST")=""
+ S ZTSAVE("GBL(")=""
+ S ZTSAVE("ROUTINE(")=""
+ S ZTRTN="TASKJOB^PXRMSXRM"
+ S ZTDESC="Clinical Reminders index build"
+ S ZTDTH=SDTIME
+ S ZTIO=""
+ D ^%ZTLOAD
+ W !,"Task number ",ZTSK," queued."
+ Q
+ ;
+ ;==========================================
+TASKJOB ;Execute as tasked job. LIST, GBL, and ROUTINE come through
+ ;ZTSAVE.
+ N IND,LI,NUM,RTN
+ S ZTREQ="@"
+ S ZTSTOP=0
+ S NUM=$L(LIST,",")-1
+ F IND=1:1:NUM D
+ .;Check to see if the task has had a stop request
+ . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q
+ . S LI=$P(LIST,",",IND)
+ . S RTN=ROUTINE(GBL(LI))
+ . D @RTN
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m

@@ -1 @@
-PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;10/11/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;==================================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate taxonomy findings.
-        N FIEVT,FINDPA,FINDING
-        N TAXIEN
-        S TAXIEN=""
-        F  S TAXIEN=$O(DEFARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0  D
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,TAXIEN,FINDING)) Q:+FINDING=0  D
-        .. K FINDPA
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. K FIEVT
-        .. D FIEVAL(DFN,TAXIEN,.FINDPA,.FIEVT)
-        .. M FIEVAL(FINDING)=FIEVT
-        Q
-        ;
-        ;==================================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;Evaluate taxonomy terms for
-        ;building patient lists.
-        N PFIND3,PFIND4,PFINDPA,TAXIEN
-        N TFINDPA,TFINDING
-        S TAXIEN=""
-        F  S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0  D
-        .. K PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D GPLIST(TAXIEN,.PFINDPA,PLIST)
-        Q
-        ;
-        ;==================================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;Evaluate taxonomy
-        ;terms.
-        N FIEVT,PFINDPA
-        N TAXIEN,TFINDPA,TFINDING
-        S TAXIEN=""
-        F  S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0  D
-        . S TFINDING=""
-        . F  S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0  D
-        .. K FIEVT,PFINDPA,TFINDPA
-        .. M TFINDPA=TERMARR(20,TFINDING)
-        ..;Set the finding parameters.
-        .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
-        .. D FIEVAL(DFN,TAXIEN,.PFINDPA,.FIEVT)
-        .. M TFIEVAL(TFINDING)=FIEVT
-        Q
-        ;
-        ;==================================================
-FIEVAL(DFN,TAXIEN,FINDPA,FIEVAL)        ;
-        N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,ENS,FIEVT,FILENUM,FLIST
-        N ICOND,IND,INS,INVFD
-        N NFOUND,NGET,NICD0,NICD9,NCPT,NOCC,NP,NRCPT,PLS
-        N RAS,SAVE,SDIR,STATUSA,TAXARR,TLIST,UCIFS,USEINP,VSLIST
-        ;Set the finding search parameters.
-        D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
-        S INVFD=$P(FINDPA(0),U,16)
-        D TAX^PXRMLDR(TAXIEN,.TAXARR)
-        I TAXARR(0)["NO LOCK" S FIEVAL(1)=0 Q
-        D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS)
-        D SCPAR^PXRMCOND(.FINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
-        S SDIR=$S(NOCC<0:+1,1:-1)
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        S NGET=$S(UCIFS:50,1:NOCC)
-        ;
-        I (NICD0>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD0",.TLIST)
-        ;
-        I (NICD9>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD9",.TLIST)
-        I (NICD9>0),ENS D FPDAT^PXRMVPOV(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
-        I (NICD9>0),PLS D
-        . K STATUSA
-        . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
-        . D FPDAT^PXRMPROB(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.STATUSA,.TLIST)
-        ;
-        I (NCPT>0),(ENS) D FPDAT^PXRMVCPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
-        ;
-        I (NRCPT>0),(RAS) D
-        . K STATUSA
-        . D GETSTATI^PXRMSTAT(70,.FINDPA,.STATUSA)
-        . D FPDAT^PXRMRCPT(DFN,.TAXARR,NOCC,BDT,EDT,.STATUSA,.TLIST)
-        ;
-        ;Process the found list, returning the NOCC most recent results.
-        S NFOUND=0
-        S DATE=""
-        F  S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC)  D
-        . S IND=0
-        . F  S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NOCC)  D
-        .. S FILENUM=0
-        .. F  S FILENUM=$O(TLIST(DATE,IND,FILENUM)) Q:FILENUM=""  D
-        ... S NFOUND=NFOUND+1
-        ... S DAS=$P(TLIST(DATE,IND,FILENUM),U,1)
-        ... S FLIST(NFOUND)=TLIST(DATE,IND,FILENUM)
-        ... S FLIST(NFOUND)=DAS_U_DATE_U_FILENUM_U_$P(TLIST(DATE,IND,FILENUM),U,2,10)
-        I NFOUND=0 S FIEVAL=0 Q
-        S NP=0
-        F IND=1:1:NFOUND Q:NP=NOCC  D
-        . S DAS=$P(FLIST(IND),U,1)
-        . S FILENUM=$P(FLIST(IND),U,3)
-        . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
-        . I $D(FIEVT("VISIT")) D GETDATA^PXRMVSIT(FIEVT("VISIT"),.FIEVT,0)
-        . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVT),1:1)
-        . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
-        . I SAVE D
-        .. S NP=NP+1
-        .. S FIEVAL(NP)=CONVAL
-        .. S FIEVAL(NP,"CONDITION")=CONVAL
-        .. S FIEVAL(NP,"CODEP")=$P(FLIST(IND),U,4)
-        .. S FIEVAL(NP,"DAS")=DAS
-        .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
-        .. S FIEVAL(NP,"FILE NUMBER")=FILENUM
-        .. S FIEVAL(NP,"FILE SPECIFIC")=$P(FLIST(IND),U,5,10)
-        .. S FIEVAL(NP,"FINDING")=TAXIEN_";PXD(811.2,"
-        .. M FIEVAL(NP)=FIEVT
-        .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVT
-        ;Save the finding result.
-        D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
-        Q
-        ;
-        ;==================================================
-GPLIST(TAXIEN,FINDPA,PLIST)     ;Get the list of patients with
-        ;taxonomy TAXIEN. Return the list as:
-        ; ^TMP($J,PLIST,T/F,DFN,TAXIEN,COUNT,FILE NUMBER)
-        ; =DAS^DATE^CODE^TYPE^file specific. TAXIEN is like the item for
-        ;non-taxonomy findings.
-        N BDT,COND,DATE,DFN,DLIST,EDT,ENS,FILENUM
-        N ICOND,IND,INS,IPLIST
-        N NF,NFOUND,NICD0,NICD9,NCPT,NF,NGET,NOCC,NRCPT
-        N PLS,RAS,STATUSA,UCIFS,USEINP,TAXARR,TF,TLIST,VSLIST
-        ;Set the finding search parameters.
-        S TLIST="GPLIST_PXRMTAX"
-        K ^TMP($J,TLIST)
-        D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
-        D TAX^PXRMLDR(TAXIEN,.TAXARR)
-        D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS)
-        D SCPAR^PXRMCOND(.FINDPA,.COND,.UCIFS,.ICOND,.VSLIST)
-        ;
-        I (NICD0>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD0",TLIST)
-        ;
-        I (NICD9>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD9",TLIST)
-        I (NICD9>0),PLS D 
-        . K STATUSA
-        . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
-        . D GPLIST^PXRMPROB(.TAXARR,NOCC,BDT,EDT,.STATUSA,TLIST)
-        I (NICD9>0),ENS D GPLIST^PXRMVPOV(.TAXARR,NOCC,BDT,EDT,TLIST)
-        ;
-        I (NCPT>0),ENS D GPLIST^PXRMVCPT(.TAXARR,NOCC,BDT,EDT,TLIST)
-        ;
-        I (NRCPT>0),RAS D GPLIST^PXRMRCPT(.TAXARR,.FINDPA,TLIST)
-        ;Conditions for taxonomies only apply to radiology findings, this
-        ;is taken care of in PXRMRCPT.
-        ;Process the found list, return up to NOCC of the most recent entries.
-        F TF=0,1 D
-        . I '$D(^TMP($J,TLIST,TF)) Q
-        . S DFN=""
-        . F  S DFN=$O(^TMP($J,TLIST,TF,DFN)) Q:DFN=""  D
-        .. K DLIST,IPLIST
-        .. S NFOUND=0
-        .. S NF=""
-        .. F  S NF=$O(^TMP($J,TLIST,TF,DFN,NF),-1) Q:NF=""  D
-        ... S FILENUM=0
-        ... F  S FILENUM=$O(^TMP($J,TLIST,TF,DFN,NF,FILENUM)) Q:FILENUM=""  D
-        .... S NFOUND=NFOUND+1
-        .... S DATE=$P(^TMP($J,TLIST,TF,DFN,NF,FILENUM),U,2)
-        .... S DLIST(DATE,NFOUND)=NF_U_FILENUM
-        ..;
-        .. S DATE="",NFOUND=0
-        .. F  S DATE=$O(DLIST(DATE),-1) Q:(DATE="")!(NFOUND=NOCC)  D
-        ... S NF=0
-        ... F  S NF=$O(DLIST(DATE,NF)) Q:(NF="")!(NFOUND=NOCC)  D
-        .... S NFOUND=NFOUND+1
-        .... S IND=$P(DLIST(DATE,NF),U,1)
-        .... S FILENUM=$P(DLIST(DATE,NF),U,2)
-        .... S IPLIST(TF,DFN,TAXIEN,NFOUND,FILENUM)=^TMP($J,TLIST,TF,DFN,IND,FILENUM)
-        .. M ^TMP($J,PLIST)=IPLIST
-        K ^TMP($J,TLIST)
-        Q
-        ;
-        ;==================================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        N IND,FILENUM,FNA,OCCLIST,TIFIEVAL
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)=""
-        S FILENUM=""
-        F  S FILENUM=$O(FNA(FILENUM)) Q:FILENUM=""  D
-        . K OCCLIST
-        . M OCCLIST=FNA(FILENUM)
-        . I FILENUM=45 D MHVOUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=70 D MHVOUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=9000010.07 D MHVOUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=9000010.18 D MHVOUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=9000011 D MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
-        Q
-        ;
-        ;==================================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        N IND,FILENUM,FNA,OCCLIST,TIFIEVAL
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)=""
-        S FILENUM=""
-        F  S FILENUM=$O(FNA(FILENUM)) Q:FILENUM=""  D
-        . K OCCLIST
-        . M OCCLIST=FNA(FILENUM)
-        . I FILENUM=45 D OUTPUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=70 D OUTPUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=9000010.07 D OUTPUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=9000010.18 D OUTPUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
-        . I FILENUM=9000011 D OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
-        Q
-        ;
+PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;==================================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate taxonomy findings.
+ N FIEVT,FINDPA,FINDING
+ N TAXIEN
+ S TAXIEN=""
+ F  S TAXIEN=$O(DEFARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0  D
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,TAXIEN,FINDING)) Q:+FINDING=0  D
+ .. K FINDPA
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. K FIEVT
+ .. D FIEVAL(DFN,TAXIEN,.FINDPA,.FIEVT)
+ .. M FIEVAL(FINDING)=FIEVT
+ Q
+ ;
+ ;==================================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate taxonomy terms for
+ ;building patient lists.
+ N PFIND3,PFIND4,PFINDPA,TAXIEN
+ N TFINDPA,TFINDING
+ S TAXIEN=""
+ F  S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0  D
+ .. K PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D GPLIST(TAXIEN,.PFINDPA,PLIST)
+ Q
+ ;
+ ;==================================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate taxonomy
+ ;terms.
+ N FIEVT,PFINDPA
+ N TAXIEN,TFINDPA,TFINDING
+ S TAXIEN=""
+ F  S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0  D
+ . S TFINDING=""
+ . F  S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0  D
+ .. K FIEVT,PFINDPA,TFINDPA
+ .. M TFINDPA=TERMARR(20,TFINDING)
+ ..;Set the finding parameters.
+ .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ .. D FIEVAL(DFN,TAXIEN,.PFINDPA,.FIEVT)
+ .. M TFIEVAL(TFINDING)=FIEVT
+ Q
+ ;
+ ;==================================================
+FIEVAL(DFN,TAXIEN,FINDPA,FIEVAL) ;
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,ENS,FIEVT,FILENUM,FLIST
+ N ICOND,IND,INS,INVFD
+ N NFOUND,NGET,NICD0,NICD9,NCPT,NOCC,NP,NRCPT,PLS
+ N RAS,SAVE,SDIR,STATUSA,TAXARR,TLIST,UCIFS,USEINP,VSLIST
+ ;Set the finding search parameters.
+ D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
+ S INVFD=$P(FINDPA(0),U,16)
+ D TAX^PXRMLDR(TAXIEN,.TAXARR)
+ I TAXARR(0)["NO LOCK" S FIEVAL(1)=0 Q
+ D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS)
+ D SCPAR^PXRMCOND(.FINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ S NGET=$S(UCIFS:"*",1:NOCC)
+ ;
+ I (NICD0>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD0",.TLIST)
+ ;
+ I (NICD9>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD9",.TLIST)
+ I (NICD9>0),ENS D FPDAT^PXRMVPOV(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
+ I (NICD9>0),PLS D
+ . K STATUSA
+ . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
+ . D FPDAT^PXRMPROB(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.STATUSA,.TLIST)
+ ;
+ I (NCPT>0),(ENS) D FPDAT^PXRMVCPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
+ ;
+ I (NRCPT>0),(RAS) D
+ . K STATUSA
+ . D GETSTATI^PXRMSTAT(70,.FINDPA,.STATUSA)
+ . D FPDAT^PXRMRCPT(DFN,.TAXARR,NOCC,BDT,EDT,.STATUSA,.TLIST)
+ ;
+ ;Process the found list, returning the NOCC most recent results.
+ S NFOUND=0
+ S DATE=""
+ F  S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC)  D
+ . S IND=0
+ . F  S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NOCC)  D
+ .. S FILENUM=0
+ .. F  S FILENUM=$O(TLIST(DATE,IND,FILENUM)) Q:FILENUM=""  D
+ ... S NFOUND=NFOUND+1
+ ... S DAS=$P(TLIST(DATE,IND,FILENUM),U,1)
+ ... S FLIST(NFOUND)=TLIST(DATE,IND,FILENUM)
+ ... S FLIST(NFOUND)=DAS_U_DATE_U_FILENUM_U_$P(TLIST(DATE,IND,FILENUM),U,2,10)
+ I NFOUND=0 S FIEVAL=0 Q
+ S NP=0
+ F IND=1:1:NFOUND Q:NP=NOCC  D
+ . S DAS=$P(FLIST(IND),U,1)
+ . S FILENUM=$P(FLIST(IND),U,3)
+ . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
+ . I $D(FIEVT("VISIT")) D GETDATA^PXRMVSIT(FIEVT("VISIT"),.FIEVT,0)
+ . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVT),1:1)
+ . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ . I SAVE D
+ .. S NP=NP+1
+ .. S FIEVAL(NP)=CONVAL
+ .. S FIEVAL(NP,"CONDITION")=CONVAL
+ .. S FIEVAL(NP,"CODEP")=$P(FLIST(IND),U,4)
+ .. S FIEVAL(NP,"DAS")=DAS
+ .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2)
+ .. S FIEVAL(NP,"FILE NUMBER")=FILENUM
+ .. S FIEVAL(NP,"FILE SPECIFIC")=$P(FLIST(IND),U,5,10)
+ .. S FIEVAL(NP,"FINDING")=TAXIEN_";PXD(811.2,"
+ .. M FIEVAL(NP)=FIEVT
+ .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVT
+ ;Save the finding result.
+ D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
+ Q
+ ;
+ ;==================================================
+GPLIST(TAXIEN,FINDPA,PLIST) ;Get the list of patients with
+ ;taxonomy TAXIEN. Return the list as:
+ ; ^TMP($J,PLIST,T/F,DFN,TAXIEN,COUNT,FILE NUMBER)
+ ; =DAS^DATE^CODE^TYPE^file specific. TAXIEN is like the item for
+ ;non-taxonomy findings.
+ N BDT,COND,DATE,DFN,DLIST,EDT,ENS,FILENUM
+ N ICOND,IND,INS,IPLIST
+ N NF,NFOUND,NICD0,NICD9,NCPT,NF,NGET,NOCC,NRCPT
+ N PLS,RAS,STATUSA,UCIFS,USEINP,TAXARR,TF,TLIST,VSLIST
+ ;Set the finding search parameters.
+ S TLIST="GPLIST_PXRMTAX"
+ K ^TMP($J,TLIST)
+ D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
+ D TAX^PXRMLDR(TAXIEN,.TAXARR)
+ D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS)
+ D SCPAR^PXRMCOND(.FINDPA,.COND,.UCIFS,.ICOND,.VSLIST)
+ ;
+ I (NICD0>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD0",TLIST)
+ ;
+ I (NICD9>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD9",TLIST)
+ I (NICD9>0),PLS D 
+ . K STATUSA
+ . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
+ . D GPLIST^PXRMPROB(.TAXARR,NOCC,BDT,EDT,.STATUSA,TLIST)
+ I (NICD9>0),ENS D GPLIST^PXRMVPOV(.TAXARR,NOCC,BDT,EDT,TLIST)
+ ;
+ I (NCPT>0),ENS D GPLIST^PXRMVCPT(.TAXARR,NOCC,BDT,EDT,TLIST)
+ ;
+ I (NRCPT>0),RAS D GPLIST^PXRMRCPT(.TAXARR,.FINDPA,TLIST)
+ ;Conditions for taxonomies only apply to radiology findings, this
+ ;is taken care of in PXRMRCPT.
+ ;Process the found list, return up to NOCC of the most recent entries.
+ F TF=0,1 D
+ . I '$D(^TMP($J,TLIST,TF)) Q
+ . S DFN=""
+ . F  S DFN=$O(^TMP($J,TLIST,TF,DFN)) Q:DFN=""  D
+ .. K DLIST,IPLIST
+ .. S NFOUND=0
+ .. S NF=""
+ .. F  S NF=$O(^TMP($J,TLIST,TF,DFN,NF),-1) Q:NF=""  D
+ ... S FILENUM=0
+ ... F  S FILENUM=$O(^TMP($J,TLIST,TF,DFN,NF,FILENUM)) Q:FILENUM=""  D
+ .... S NFOUND=NFOUND+1
+ .... S DATE=$P(^TMP($J,TLIST,TF,DFN,NF,FILENUM),U,2)
+ .... S DLIST(DATE,NFOUND)=NF_U_FILENUM
+ ..;
+ .. S DATE="",NFOUND=0
+ .. F  S DATE=$O(DLIST(DATE),-1) Q:(DATE="")!(NFOUND=NOCC)  D
+ ... S NF=0
+ ... F  S NF=$O(DLIST(DATE,NF)) Q:(NF="")!(NFOUND=NOCC)  D
+ .... S NFOUND=NFOUND+1
+ .... S IND=$P(DLIST(DATE,NF),U,1)
+ .... S FILENUM=$P(DLIST(DATE,NF),U,2)
+ .... S IPLIST(TF,DFN,TAXIEN,NFOUND,FILENUM)=^TMP($J,TLIST,TF,DFN,IND,FILENUM)
+ .. M ^TMP($J,PLIST)=IPLIST
+ K ^TMP($J,TLIST)
+ Q
+ ;
+ ;==================================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N IND,FILENUM,FNA,OCCLIST,TIFIEVAL
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)=""
+ S FILENUM=""
+ F  S FILENUM=$O(FNA(FILENUM)) Q:FILENUM=""  D
+ . K OCCLIST
+ . M OCCLIST=FNA(FILENUM)
+ . I FILENUM=45 D MHVOUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=70 D MHVOUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=9000010.07 D MHVOUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=9000010.18 D MHVOUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=9000011 D MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
+ Q
+ ;
+ ;==================================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ N IND,FILENUM,FNA,OCCLIST,TIFIEVAL
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)=""
+ S FILENUM=""
+ F  S FILENUM=$O(FNA(FILENUM)) Q:FILENUM=""  D
+ . K OCCLIST
+ . M OCCLIST=FNA(FILENUM)
+ . I FILENUM=45 D OUTPUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=70 D OUTPUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=9000010.07 D OUTPUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=9000010.18 D OUTPUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+ . I FILENUM=9000011 D OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m

@@ -1 @@
-PXRMTERM        ; SLC/PKR - Handle reminder terms. ;04/23/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=============================================
-COPY(NOCC,SDIR,TFIEVAL,DATEORDR,FINDING,FIEVAL) ;Copy the NOCC date ordered
-        ;findings from TFIEVAL to FIEVAL(FINDING).
-        N DATE,IND,JND,MRS,NFOUND,TFI
-        ;Start with most recent and go to oldest finding.
-        S MRS=1
-        S NFOUND=0
-        S DATE=""
-        F  S DATE=$O(DATEORDR(DATE),SDIR) Q:(NFOUND=NOCC)!(DATE="")  D
-        . S TFI=0
-        . F  S TFI=$O(DATEORDR(DATE,TFI)) Q:(NFOUND=NOCC)!(TFI="")  D
-        .. I MRS D
-        ...;Save the main result node.
-        ... S FIEVAL(FINDING)=TFIEVAL(TFI)
-        ... S MRS=0
-        ... I 'FIEVAL(FINDING) Q
-        ... S JND="@"
-        ... F  S JND=$O(TFIEVAL(TFI,JND)) Q:JND=""  M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
-        .. I 'FIEVAL(FINDING) Q
-        .. S IND=0
-        .. F  S IND=$O(DATEORDR(DATE,TFI,IND)) Q:(NFOUND=NOCC)!(IND="")  D
-        ...;Only save true sub-results.
-        ... I 'TFIEVAL(TFI,IND) Q
-        ... S NFOUND=NFOUND+1
-        ... M FIEVAL(FINDING,NFOUND)=TFIEVAL(TFI,IND)
-        ... S FIEVAL(FINDING,NFOUND,"FILE NUMBER")=TFIEVAL(TFI,"FILE NUMBER")
-        ... S FIEVAL(FINDING,NFOUND,"FINDING")=TFIEVAL(TFI,"FINDING")
-        ... S JND=0
-        ... F  S JND=$O(TFIEVAL(TFI,IND,JND)) Q:JND=""  M FIEVAL(FINDING,NFOUND,JND)=TFIEVAL(TFI,IND,JND)
-        Q
-        ;
-        ;=============================================
-DORDER(TFIEVAL,DATEORDR)        ;Order term findings by date, term finding,
-        ;and term finding occurrence.
-        N DATE,FI,IND
-        K DATEORDR
-        S FI=0
-        F  S FI=+$O(TFIEVAL(FI)) Q:FI=0  D
-        . S IND=0
-        . F  S IND=+$O(TFIEVAL(FI,IND)) Q:IND=0  D
-        .. S DATE=$G(TFIEVAL(FI,IND,"DATE"))
-        .. I DATE'="" S DATEORDR(DATE,FI,IND)=""
-        Q
-        ;
-        ;=============================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate all reminder terms in a
-        ;definition.
-        N CASESEN,CONVAL,DATE,DATEORDR
-        N FIEVT,FINDING,FINDPA,IND,NOCC
-        N SDIR,TFIND3,TFIND4,TERMARR,TERMIEN,TFI,TFIEVAL,UCIFS
-        S TERMIEN=""
-        F  S TERMIEN=$O(DEFARR("E",ENODE,TERMIEN)) Q:+TERMIEN=0  D
-        . I '$D(^PXRMD(811.5,TERMIEN,20,"E")) D  Q
-        .. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFI",TERMIEN)="Warning no findings items in reminder term "_$P(^PXRMD(811.5,TERMIEN,0),U,1)
-        .. S FINDING=""
-        .. F  S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:FINDING=""  S FIEVAL(FINDING)=0
-        . D TERM^PXRMLDR(TERMIEN,.TERMARR)
-        . S FINDING=""
-        . F  S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:+FINDING=0  D
-        .. S FIEVAL(FINDING)=0
-        .. S FIEVAL(FINDING,"TERM")=TERMARR(0)
-        .. S FIEVAL(FINDING,"TERM IEN")=TERMIEN
-        .. K FINDPA,TFIEVAL
-        .. M FINDPA=DEFARR(20,FINDING)
-        .. D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
-        .. I $G(PXRMTDEB) M ^TMP("PXRMTDEB",$J,FINDING)=TFIEVAL
-        ..;Set NOCC and SDIR.
-        .. S NOCC=$P(FINDPA(0),U,14)
-        .. I NOCC="" S NOCC=1
-        .. S SDIR=$S(NOCC<0:+1,1:-1)
-        .. S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        ..;Order the term findings by date.
-        .. D DORDER(.TFIEVAL,.DATEORDR)
-        .. D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL)
-        Q
-        ;
-        ;=============================================
-EVALTERM(DFN,FINDPA,TERMARR,TFIEVAL)    ;Evaluate all the findings in
-        ;a term. Use the "E" cross-reference just like the finding evaluation.
-        N ENODE
-        S ENODE=""
-        F  S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE=""  D
-        . I ENODE="AUTTEDT(" D EVALTERM^PXRMEDU(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="AUTTEXAM(" D EVALTERM^PXRMEXAM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="AUTTHF(" D EVALTERM^PXRMHF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="AUTTIMM(" D EVALTERM^PXRMIMM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="AUTTSK(" D EVALTERM^PXRMSKIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="GMRD(120.51," D EVALTERM^PXRMVITL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="LAB(60," D EVALTERM^PXRMLAB(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="ORD(101.43," D EVALTERM^PXRMORDR(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PXD(811.2," D EVALTERM^PXRMTAX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PXRMD(810.9," D EVALTERM^PXRMLOCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PXRMD(811.4," D EVALTERM^PXRMCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PS(50.605," D EVALTERM^PXRMDRCL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PS(55," D EVALTERM^PXRMDIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PS(55NVA," D EVALTERM^PXRMDNVA(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PSDRUG(" D EVALTERM^PXRMDRUG(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PSRX(" D EVALTERM^PXRMDOUT(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="PSNDF(50.6," D EVALTERM^PXRMDGEN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="RAMIS(71," D EVALTERM^PXRMRAD(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        . I ENODE="YTT(601.71," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
-        Q
-        ;
-        ;=============================================
-IEVALTER(DFN,FINDPA,TERMARR,FINDING,FIEVAL)     ;Evaluate an individual term
-        ;put the result in FIEVAL(FINDING).
-        N DATEORDR,NOCC,SDIR,TFIEVAL
-        I $D(PXRMPDEM) G DEMOK
-        N PXRMPDEM D DEM^PXRMPINF(DFN,DT,.PXRMPDEM)
-        ;Create the local demographic variables for use in Condition.
-        N PXRMAGE,PXRMDOB,PXRMDOD,PXRMLAD,PXRMSEX
-        S PXRMAGE=PXRMPDEM("AGE"),PXRMDOB=PXRMPDEM("DOB"),PXRMDOD=PXRMPDEM("DOD")
-        S PXRMLAD=PXRMPDEM("LAD"),PXRMSEX=PXRMPDEM("SEX")
-DEMOK   S FIEVAL(FINDING)=0
-        D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
-        ;Set NOCC and SDIR.
-        S NOCC=$P(FINDPA(0),U,14)
-        I NOCC="" S NOCC=1
-        S SDIR=$S(NOCC<0:+1,1:-1)
-        S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
-        ;Order the term findings by date.
-        D DORDER(.TFIEVAL,.DATEORDR)
-        D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL)
-        Q
-        ;
-        ;=============================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"MHV")
-        Q
-        ;
-        ;=============================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"CM")
-        Q
-        ;
-        ;=============================================
-OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE)    ;General output.
-        N DG,DGL,DGN,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
-        ;Build the display grouping.
-        S FILENUM=IFIEVAL(1,"FILE NUMBER")
-        S IEN=$P(IFIEVAL(1,"FINDING"),";",1)
-        S DG(FILENUM,IEN)=1,DGL(1)=FILENUM_U_IEN,DGL(1,1)=""
-        S (DGN,IND)=1
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S FILENUM=IFIEVAL(IND,"FILE NUMBER")
-        . S IEN=$P(IFIEVAL(IND,"FINDING"),";",1)
-        . I '$D(DG(FILENUM,IEN)) D
-        .. S DGN=DGN+1,DG(FILENUM,IEN)=DGN
-        .. S DGL(DGN)=FILENUM_U_IEN,DGL(DGN,IND)=""
-        . I $D(DG(FILENUM,IEN)) D
-        .. S TEMP=DG(FILENUM,IEN),DGL(TEMP,IND)=""
-        S INDENTT=INDENT+1
-        S TEMP=$$INSCHR^PXRMEXLC(INDENT," ")_"Reminder Term: "_$P(FIEVAL(FINDING,"TERM"),U,1)
-        S NLINES=NLINES+1,TEXT(NLINES)=TEMP
-        F IND=1:1:DGN D
-        . K TIFIEVAL
-        . S (JND,KND)=0
-        . F  S JND=$O(DGL(IND,JND)) Q:JND=""  D
-        .. S KND=KND+1
-        .. I KND=1 M TIFIEVAL=IFIEVAL(JND)
-        .. M TIFIEVAL(KND)=IFIEVAL(JND)
-        . I TYPE="CM" D FOUT^PXRMOUTC(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
-        . I TYPE="MHV" D FOUT^PXRMOUTM(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
-        Q
-        ;
-        ;=============================================
-SPFINDPA(FINDPA,TFINDPA,PFINDPA)        ;Set the finding parameter array
-        ;for terms.
-        N FIND0,PIECE,PFIND0,TFIND0,VAL
-        S FIND0=$G(FINDPA(0))
-        S (PFIND0,TFIND0)=TFINDPA(0)
-        ;Set the 0 node.
-        F PIECE=9,10,12,13,14,15,16 D
-        . S VAL=$P(TFIND0,U,PIECE)
-        . I VAL="" S VAL=$P(FIND0,U,PIECE)
-        . S $P(PFIND0,U,PIECE)=VAL
-        ;BDT and EDT are treated as a pair.
-        I $P(TFIND0,U,8)="",$P(TFIND0,U,11)="" F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(FIND0,U,PIECE)
-        E  F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(TFIND0,U,PIECE)
-        S PFINDPA(0)=PFIND0
-        I $P($G(TFINDPA(3)),U,1)'="" S PFINDPA(3)=TFINDPA(3),PFINDPA(10)=TFINDPA(10),PFINDPA(11)=TFINDPA(11)
-        E  S PFINDPA(3)=$G(FINDPA(3)),PFINDPA(10)=$G(FINDPA(10)),PFINDPA(11)=$G(FINDPA(11))
-        ;Get the status list.
-        I $D(TFINDPA(5)) M PFINDPA(5)=TFINDPA(5)
-        E  M PFINDPA(5)=FINDPA(5)
-        I $D(TFINDPA(15)) S PFINDPA(15)=TFINDPA(15)
-        E  S PFINDPA(15)=$G(FINDPA(15))
-        Q
-        ;
+PXRMTERM ; SLC/PKR - Handle reminder terms. ;06/29/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=============================================
+COPY(NOCC,SDIR,TFIEVAL,DATEORDR,FINDING,FIEVAL) ;Copy the NOCC date ordered
+ ;findings from TFIEVAL to FIEVAL(FINDING).
+ N DATE,IND,JND,MRS,NFOUND,TFI
+ ;Start with most recent and go to oldest finding.
+ S MRS=1
+ S NFOUND=0
+ S DATE=""
+ F  S DATE=$O(DATEORDR(DATE),SDIR) Q:(NFOUND=NOCC)!(DATE="")  D
+ . S TFI=0
+ . F  S TFI=$O(DATEORDR(DATE,TFI)) Q:(NFOUND=NOCC)!(TFI="")  D
+ .. I MRS D
+ ...;Save the main result node.
+ ... S FIEVAL(FINDING)=TFIEVAL(TFI)
+ ... S MRS=0
+ ... I 'FIEVAL(FINDING) Q
+ ... S JND="@"
+ ... F  S JND=$O(TFIEVAL(TFI,JND)) Q:JND=""  D
+ .... M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
+ .. I 'FIEVAL(FINDING) Q
+ .. S IND=0
+ .. F  S IND=$O(DATEORDR(DATE,TFI,IND)) Q:(NFOUND=NOCC)!(IND="")  D
+ ...;Only save true sub-results.
+ ... I 'TFIEVAL(TFI,IND) Q
+ ... S NFOUND=NFOUND+1
+ ... M FIEVAL(FINDING,NFOUND)=TFIEVAL(TFI,IND)
+ ... S FIEVAL(FINDING,NFOUND,"FILE NUMBER")=TFIEVAL(TFI,"FILE NUMBER")
+ ... S FIEVAL(FINDING,NFOUND,"FINDING")=TFIEVAL(TFI,"FINDING")
+ ... S JND=0
+ ... F  S JND=$O(TFIEVAL(TFI,IND,JND)) Q:JND=""  M FIEVAL(FINDING,NFOUND,JND)=TFIEVAL(TFI,IND,JND)
+ Q
+ ;
+ ;=============================================
+DORDER(TFIEVAL,DATEORDR) ;Order term findings by date, term finding,
+ ;and term finding occurrence.
+ N DATE,FI,IND
+ K DATEORDR
+ S FI=0
+ F  S FI=+$O(TFIEVAL(FI)) Q:FI=0  D
+ . S IND=0
+ . F  S IND=+$O(TFIEVAL(FI,IND)) Q:IND=0  D
+ .. S DATE=$G(TFIEVAL(FI,IND,"DATE"))
+ .. I DATE'="" S DATEORDR(DATE,FI,IND)=""
+ Q
+ ;
+ ;=============================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate all reminder terms in a
+ ;definition.
+ N CASESEN,CONVAL,DATE,DATEORDR
+ N FIEVT,FINDING,FINDPA,IND,NOCC
+ N SDIR,TFIND3,TFIND4,TERMARR,TERMIEN,TFI,TFIEVAL,UCIFS
+ S TERMIEN=""
+ F  S TERMIEN=$O(DEFARR("E",ENODE,TERMIEN)) Q:+TERMIEN=0  D
+ . I '$D(^PXRMD(811.5,TERMIEN,20,"E")) D  Q
+ .. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFI",TERMIEN)="Warning no findings items in reminder term "_$P(^PXRMD(811.5,TERMIEN,0),U,1)
+ .. S FINDING=""
+ .. F  S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:FINDING=""  S FIEVAL(FINDING)=0
+ . D TERM^PXRMLDR(TERMIEN,.TERMARR)
+ . S FINDING=""
+ . F  S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:+FINDING=0  D
+ .. S FIEVAL(FINDING)=0
+ .. S FIEVAL(FINDING,"TERM")=TERMARR(0)
+ .. S FIEVAL(FINDING,"TERM IEN")=TERMIEN
+ .. K FINDPA,TFIEVAL
+ .. M FINDPA=DEFARR(20,FINDING)
+ .. D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
+ .. I $G(PXRMTDEB) M ^TMP("PXRMTDEB",$J,FINDING)=TFIEVAL
+ ..;Set NOCC and SDIR.
+ .. S NOCC=$P(FINDPA(0),U,14)
+ .. I NOCC="" S NOCC=1
+ .. S SDIR=$S(NOCC<0:+1,1:-1)
+ .. S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ ..;Order the term findings by date.
+ .. D DORDER(.TFIEVAL,.DATEORDR)
+ .. D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL)
+ Q
+ ;
+ ;=============================================
+EVALPL(FINDPA,TERMARR,PLIST) ;Build a list of patients based on a
+ ;term. The list is returned in:
+ ;^TMP($J,PLIST,T/F,DFN,ITEM,NFOUND,FILENUM)=DAS_U_DATE_U_VALUE
+ ;for findings with a start and stop date the list is
+ ;^TMP($J,PLIST,T/F,DFN,ITEM,NFOUND,FILENUM)=DAS_U_START_U_STOP_U_VALUE
+ N ENODE
+ K ^TMP($J,PLIST)
+ S ENODE=""
+ F  S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE=""  D
+ . I ENODE="AUTTEDT(" D EVALPL^PXRMEDU(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTEXAM(" D EVALPL^PXRMEXAM(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTHF(" D EVALPL^PXRMHF(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTIMM(" D EVALPL^PXRMIMM(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTSK(" D EVALPL^PXRMSKIN(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="GMRD(120.51," D EVALPL^PXRMVITL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="LAB(60," D EVALPL^PXRMLAB(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="ORD(101.43," D EVALPL^PXRMORDR(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXRMD(810.9," D EVALPL^PXRMLOCL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXD(811.2," D EVALPL^PXRMTAX(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXRMD(811.4," D EVALPL^PXRMCF(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PS(50.605," D EVALPL^PXRMDRCL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PSDRUG(" D EVALPL^PXRMDRUG(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PSNDF(50.6," D EVALPL^PXRMDGEN(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="RAMIS(71," D EVALPL^PXRMRAD(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="YTT(601," D EVALPL^PXRMMH(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ Q
+ ;
+ ;=============================================
+EVALTERM(DFN,FINDPA,TERMARR,TFIEVAL) ;Evaluate all the findings in
+ ;a term. Use the "E" cross-reference just like the finding evaluation.
+ N ENODE
+ S ENODE=""
+ F  S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE=""  D
+ . I ENODE="AUTTEDT(" D EVALTERM^PXRMEDU(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="AUTTEXAM(" D EVALTERM^PXRMEXAM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="AUTTHF(" D EVALTERM^PXRMHF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="AUTTIMM(" D EVALTERM^PXRMIMM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="AUTTSK(" D EVALTERM^PXRMSKIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="GMRD(120.51," D EVALTERM^PXRMVITL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="LAB(60," D EVALTERM^PXRMLAB(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="ORD(101.43," D EVALTERM^PXRMORDR(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PXD(811.2," D EVALTERM^PXRMTAX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PXRMD(810.9," D EVALTERM^PXRMLOCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PXRMD(811.4," D EVALTERM^PXRMCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PS(50.605," D EVALTERM^PXRMDRCL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PS(55," D EVALTERM^PXRMDIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PS(55NVA," D EVALTERM^PXRMDNVA(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PSDRUG(" D EVALTERM^PXRMDRUG(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PSRX(" D EVALTERM^PXRMDOUT(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="PSNDF(50.6," D EVALTERM^PXRMDGEN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="RAMIS(71," D EVALTERM^PXRMRAD(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="YTT(601," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ Q
+ ;
+ ;=============================================
+IEVALTER(DFN,FINDPA,TERMARR,FINDING,FIEVAL) ;Evaluate an individual term
+ ;put the result in FIEVAL(FINDING).
+ N DATEORDR,NOCC,SDIR,TFIEVAL
+ I $D(PXRMPDEM) G DEMOK
+ N PXRMPDEM D DEM^PXRMPINF(DFN,DT,.PXRMPDEM)
+ ;Create the local demographic variables for use in Condition.
+ N PXRMAGE,PXRMDOB,PXRMDOD,PXRMLAD,PXRMSEX
+ S PXRMAGE=PXRMPDEM("AGE"),PXRMDOB=PXRMPDEM("DOB"),PXRMDOD=PXRMPDEM("DOD")
+ S PXRMLAD=PXRMPDEM("LAD"),PXRMSEX=PXRMPDEM("SEX")
+DEMOK S FIEVAL(FINDING)=0
+ D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
+ ;Set NOCC and SDIR.
+ S NOCC=$P(FINDPA(0),U,14)
+ I NOCC="" S NOCC=1
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
+ ;Order the term findings by date.
+ D DORDER(.TFIEVAL,.DATEORDR)
+ D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL)
+ Q
+ ;
+ ;=============================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"MHV")
+ Q
+ ;
+ ;=============================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"CM")
+ Q
+ ;
+ ;=============================================
+OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE) ;General output.
+ N DG,DGL,DGN,DRUG,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
+ ;If there is a drug make it available for display.
+ S DRUG=$S($D(IFIEVAL("DISPENSE DRUG")):IFIEVAL("DISPENSE DRUG"),1:"")
+ ;DBIA #10043
+ I DRUG'="" S DRUG=$P(^PSDRUG(DRUG,0),U,1)
+ ;Build the display grouping.
+ S FILENUM=IFIEVAL(1,"FILE NUMBER")
+ S IEN=$P(IFIEVAL(1,"FINDING"),";",1)
+ S DG(FILENUM,IEN)=1,DGL(1)=FILENUM_U_IEN,DGL(1,1)=""
+ S (DGN,IND)=1
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S FILENUM=IFIEVAL(IND,"FILE NUMBER")
+ . S IEN=$P(IFIEVAL(IND,"FINDING"),";",1)
+ . I '$D(DG(FILENUM,IEN)) D
+ .. S DGN=DGN+1,DG(FILENUM,IEN)=DGN
+ .. S DGL(DGN)=FILENUM_U_IEN,DGL(DGN,IND)=""
+ . I $D(DG(FILENUM,IEN)) D
+ .. S TEMP=DG(FILENUM,IEN),DGL(TEMP,IND)=""
+ S INDENTT=INDENT+1
+ S TEMP=$$INSCHR^PXRMEXLC(INDENT," ")_"Reminder Term: "_$P(FIEVAL(FINDING,"TERM"),U,1)
+ S NLINES=NLINES+1,TEXT(NLINES)=TEMP
+ F IND=1:1:DGN D
+ . K TIFIEVAL
+ . S (JND,KND)=0
+ . F  S JND=$O(DGL(IND,JND)) Q:JND=""  D
+ .. S KND=KND+1
+ .. I KND=1 M TIFIEVAL=IFIEVAL(JND)
+ .. M TIFIEVAL(KND)=IFIEVAL(JND)
+ .. I DRUG'="" S TIFIEVAL("DISPENSE DRUG")=DRUG
+ . I TYPE="CM" D FOUT^PXRMOUTC(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
+ . I TYPE="MHV" D FOUT^PXRMOUTM(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
+ Q
+ ;
+ ;=============================================
+SPFINDPA(FINDPA,TFINDPA,PFINDPA) ;Set the finding parameter array
+ ;for terms.
+ N FIND0,PIECE,PFIND0,TFIND0,VAL
+ S FIND0=$G(FINDPA(0))
+ S (PFIND0,TFIND0)=TFINDPA(0)
+ ;Set the 0 node.
+ F PIECE=9,10,12,13,14,15,16 D
+ . S VAL=$P(TFIND0,U,PIECE)
+ . I VAL="" S VAL=$P(FIND0,U,PIECE)
+ . S $P(PFIND0,U,PIECE)=VAL
+ ;BDT and EDT are treated as a pair.
+ I $P(TFIND0,U,8)="",$P(TFIND0,U,11)="" F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(FIND0,U,PIECE)
+ E  F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(TFIND0,U,PIECE)
+ S PFINDPA(0)=PFIND0
+ I $P($G(TFINDPA(3)),U,1)'="" S PFINDPA(3)=TFINDPA(3),PFINDPA(10)=TFINDPA(10),PFINDPA(11)=TFINDPA(11)
+ E  S PFINDPA(3)=$G(FINDPA(3)),PFINDPA(10)=$G(FINDPA(10)),PFINDPA(11)=$G(FINDPA(11))
+ ;Get the status list.
+ I $D(TFINDPA(5)) M PFINDPA(5)=TFINDPA(5)
+ E  M PFINDPA(5)=FINDPA(5)
+ I $D(TFINDPA(15)) S PFINDPA(15)=TFINDPA(15)
+ E  S PFINDPA(15)=$G(FINDPA(15))
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m

@@ -1 @@
-PXRMTEXT        ; SLC/PKR - Text formatting utility routines. ;07/19/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;============================================
-NEWLINE ;Put TEXT on a new line to the output, make sure it does not end
-        ;with a " ".
-        N TLEN
-        ;If there is no text in TEXT don't do anything.
-        I TEXT=INDSTR Q
-        S TLEN=$L(TEXT)
-        I $E(TEXT,TLEN)=" " S TEXT=$E(TEXT,1,TLEN-1)
-        S NOUT=NOUT+1,TEXTOUT(NOUT)=TEXT
-        S TEXT=INDSTR,CLEN=0
-        Q
-        ;
-        ;============================================
-BLANK   ;Add a blank line (line containing just " ") to the output.
-        S NOUT=NOUT+1,TEXTOUT(NOUT)=" "
-        S TEXT=INDSTR,CLEN=0
-        Q
-        ;
-        ;============================================
-CHECKLEN(WORD)  ;Check to see if adding the next word makes the line too long.
-        ;If it does add it to the output and start a new line.
-        N LENWORD
-        S LENWORD=$L(WORD)
-        I (CLEN+LENWORD)>WIDTH D
-        . D NEWLINE
-        . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1
-        . S TEXT=INDSTR_WORD,CLEN=LENWORD
-        E  D
-        . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1
-        . S TEXT=TEXT_WORD,CLEN=CLEN+LENWORD
-        Q
-        ;
-        ;============================================
-COLFMT(FMTSTR,TEXTSTR,PC,NL,OUTPUT)     ;Columnar text formatter.
-        ;FMTSTR - format string; ^ separated string for each column in the
-        ;output. 35R2 defines a right justified column 35 characters wide
-        ;with 2 blank spaces following. Columns can be centered (C) left
-        ;justified (L) or right justified (R).
-        ;TEXTSTR - string to be formated
-        ;PC - the pad character
-        ;NL - number of lines of output
-        ;OUTPUT - array containing output lines.
-        N COLOUT,ENTRY,FMT,JND,JUS,IND,LEN,NCOL,NLO,NROW,SP,TEMP,TEXT,WIDTH,WPSP
-        S NCOL=$L(FMTSTR,U),NROW=1
-        F IND=1:1:NCOL D
-        . S FMT=$P(FMTSTR,U,IND)
-        . S JUS(IND)=$S(FMT["C":"C",FMT["L":"L",FMT["R":"R",1:"C")
-        . S WIDTH(IND)=$P(FMT,JUS(IND),1)
-        . S SP(IND)=$P(FMT,JUS(IND),2)
-        . S WPSP(IND)=WIDTH(IND)+SP(IND)
-        F IND=1:1:NCOL D
-        . S ENTRY=$S(JUS(IND)="C":"CJ",JUS(IND)="L":"LJ",JUS(IND)="R":"RJ")
-        . S TEMP=$P(TEXTSTR,U,IND)
-        . S LEN=$L(TEMP)
-        . I LEN'>WIDTH(IND) D
-        .. S TEMP=$$@ENTRY^XLFSTR(TEMP,WIDTH(IND),PC)
-        .. S COLOUT(1,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
-        . I LEN>WIDTH(IND) D
-        .. D FORMATS(1,WIDTH(IND),TEMP,.NLO,.TEXTOUT)
-        .. F JND=1:1:NLO D
-        ... S TEMP=$$@ENTRY^XLFSTR(TEXTOUT(JND),WIDTH(IND),PC)
-        ... S COLOUT(JND,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
-        .. I NLO>NROW S NROW=NLO
-        F IND=1:1:NROW D
-        . S TEXT=""
-        . F JND=1:1:NCOL D
-        .. I $D(COLOUT(IND,JND)) S TEXT=TEXT_COLOUT(IND,JND)
-        .. E  S TEXT=TEXT_$$LJ^XLFSTR("",(WPSP(JND))," ")
-        . S OUTPUT(IND)=TEXT
-        S NL=NROW
-        Q
-        ;
-        ;============================================
-COLFMTA(FMTSTR,INPUT,PC,NL,OUTPUT)      ;Columnar text formatter.
-        ;Array version of COLFMT. Input array is ^TMP($J,INPUT,M) and
-        ;output is ^TMP(OUTPUT,$J,N,0).
-        N COLOUT,ENTRY,FMT,JND,JUS,IND,LEN,NCOL,NLO,NROW,NUM
-        N SP,TEMP,TEXT,WIDTH,WPSP
-        S NCOL=$L(FMTSTR,U)
-        F IND=1:1:NCOL D
-        . S FMT=$P(FMTSTR,U,IND)
-        . S JUS(IND)=$S(FMT["C":"C",FMT["L":"L",FMT["R":"R",1:"C")
-        . S WIDTH(IND)=$P(FMT,JUS(IND),1)
-        . S SP(IND)=$P(FMT,JUS(IND),2)
-        . S WPSP(IND)=WIDTH(IND)+SP(IND)
-        S NL=0,NUM=""
-        F  S NUM=$O(^TMP($J,INPUT,NUM)) Q:NUM=""  D
-        . K COLOUT
-        . S NROW=1
-        . F IND=1:1:NCOL D
-        .. S ENTRY=$S(JUS(IND)="C":"CJ",JUS(IND)="L":"LJ",JUS(IND)="R":"RJ")
-        .. S TEMP=$P(^TMP($J,INPUT,NUM),U,IND)
-        .. S LEN=$L(TEMP)
-        .. I LEN'>WIDTH(IND) D
-        ... S TEMP=$$@ENTRY^XLFSTR(TEMP,WIDTH(IND),PC)
-        ... S COLOUT(1,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
-        .. I LEN>WIDTH(IND) D
-        ... D FORMATS(1,WIDTH(IND),TEMP,.NLO,.TEXTOUT)
-        ... F JND=1:1:NLO D
-        .... S TEMP=$$@ENTRY^XLFSTR(TEXTOUT(JND),WIDTH(IND),PC)
-        .... S COLOUT(JND,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
-        ... I NLO>NROW S NROW=NLO
-        . F IND=1:1:NROW D
-        .. S TEXT=""
-        .. F JND=1:1:NCOL D
-        ... I $D(COLOUT(IND,JND)) S TEXT=TEXT_COLOUT(IND,JND)
-        ... E  S TEXT=TEXT_$$LJ^XLFSTR("",(WPSP(JND))," ")
-        .. S NL=NL+1,^TMP(OUTPUT,$J,NL,0)=TEXT
-        Q
-        ;
-        ;============================================
-FORMAT(LM,RM,NIN,TEXTIN,NOUT,TEXTOUT)   ;Format the text in TEXTIN so it has
-        ;a left margin of LM and a right margin of RM. The formatted text
-        ;is in TEXTOUT. "\\" is the end of line marker. Lines ending with
-        ;"\\" will not have anything appended to them. A blank line can
-        ;be created by creating a line containing just "\\". Lines containing
-        ;nothing but whitespace will also act like a "\\".
-        I NIN=0 S NOUT=0 Q
-        N ACHAR,ALLWSP,CHAR,CLEN,END,IND,INDENT,INDSTR,JND
-        N LWSP,NWSP,START,TEMP,TEXT,TLEN,WIDTH,W1,W2,WORD
-        ;Catalog the whitespace so we have places to break and look for
-        ;end of line markers.
-        F IND=1:1:NIN D
-        . S TEMP=TEXTIN(IND)
-        . S TLEN=$L(TEMP)
-        . S ALLWSP=1,NWSP=0
-        . F JND=1:1:TLEN D
-        .. S CHAR=$E(TEMP,JND)
-        .. S ACHAR=$A(CHAR)
-        .. I ACHAR>32 S ALLWSP=0
-        .. E  S NWSP=NWSP+1,LWSP(IND,NWSP)=JND
-        .;Mark the end of the line.
-        . S NWSP=NWSP+1,LWSP(IND,NWSP)=TLEN,LWSP(IND)=NWSP
-        . I ALLWSP S LWSP(IND,"ALLWSP")=""
-        I LM<1 S LM=1
-        S WIDTH=RM-LM+1
-        S INDENT=LM-1
-        S INDSTR=""
-        F IND=1:1:INDENT S INDSTR=INDSTR_" "
-        S NOUT=0
-        S TEXT=INDSTR,CLEN=0
-        F IND=1:1:NIN D
-        .;If there is a blank line force whatever is in TEXT to be output by
-        .;calling NEWLINE and then add the blank.
-        . I $D(LWSP(IND,"ALLWSP")) D NEWLINE,BLANK Q
-        . S TEMP=TEXTIN(IND)
-        . S (END,NWSP)=0
-        . F NWSP=1:1:LWSP(IND) D
-        .. S START=END+1,END=LWSP(IND,NWSP)
-        .. S WORD=$E(TEMP,START,END)
-        .. I WORD["\\" D  Q
-        ... S W1=$P(WORD,"\\",1)
-        ... D CHECKLEN(W1)
-        ... D NEWLINE
-        ... S W2=$P(WORD,"\\",2)
-        ... I W2'="" D CHECKLEN(W2)
-        .. D CHECKLEN(WORD)
-        ;Output the last line.
-        D NEWLINE
-        Q
-        ;
-        ;============================================
-FORMATS(LM,RM,TEXTLINE,NOUT,TEXTOUT)    ;Take a single line of input text
-        ;and format it.
-        N TEXTIN
-        S TEXTIN(1)=TEXTLINE
-        D FORMAT(LM,RM,1,.TEXTIN,.NOUT,.TEXTOUT)
-        Q
-        ;
-        ;============================================
-LMFMTSTR(VALMDDF,JSTR)  ;The List Manager variable VALMDDF contains the
-        ;list template caption column formatting information. It contains
-        ;the starting column and the width if the form
-        ;VALMDDF(COLUMN NAME)=COLUMN NAME^COLUMN^WIDTH^CAPTION^VIDEO^SCROLL
-        ;LOCK. JUSSTR, which is optional,is the justification for each column;
-        ;(L=left, C=center, R=right) the default is center. Use this information
-        ;to build the format string for the column formatter COLFMT.
-        N CN,COL,FMTSTR,IND,JC,JUSSTR,PLCOL,SCOL,SP,TEMP,WIDTH
-        ;Sort by columns
-        S IND=""
-        F  S IND=$O(VALMDDF(IND)) Q:IND=""  D
-        . S TEMP=VALMDDF(IND)
-        . S COL($P(TEMP,U,2))=$P(TEMP,U,3)
-        S JUSSTR=$G(JSTR)
-        S (CN,PLCOL,SCOL,SP)=0
-        S FMTSTR=""
-        S SCOL=0
-        F  S SCOL=$O(COL(SCOL)) Q:SCOL=""  D
-        . S CN=CN+1
-        . S WIDTH=COL(SCOL)
-        . I CN=1 S PLCOL=WIDTH
-        . E  S SP=SCOL-PLCOL-1,FMTSTR=FMTSTR_SP_U,PLCOL=SCOL+WIDTH-1
-        . S JC=$E(JUSSTR,CN)
-        . I JC="" S JC="C"
-        . S TEMP=WIDTH_JC
-        . S FMTSTR=FMTSTR_TEMP
-        Q FMTSTR
-        ;
+PXRMTEXT ; SLC/PKR - Text formatting utility routines. ;11/03/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;================================================================
+NEWLINE ;Put TEXT on a new line to the output, make sure it does not end
+ ;with a " ".
+ N TLEN
+ ;If there is no text in TEXT don't do anything.
+ I TEXT=INDSTR Q
+ S TLEN=$L(TEXT)
+ I $E(TEXT,TLEN)=" " S TEXT=$E(TEXT,1,TLEN-1)
+ S NOUT=NOUT+1,TEXTOUT(NOUT)=TEXT
+ S TEXT=INDSTR,CLEN=0
+ Q
+ ;
+ ;================================================================
+BLANK ;Add a blank line (line containing just " ") to the output.
+ S NOUT=NOUT+1,TEXTOUT(NOUT)=" "
+ S TEXT=INDSTR,CLEN=0
+ Q
+ ;
+ ;================================================================
+CHECKLEN(WORD) ;Check to see if adding the next word makes the line too long.
+ ;If it does add it to the output and start a new line.
+ N LENWORD
+ S LENWORD=$L(WORD)
+ I (CLEN+LENWORD)>WIDTH D
+ . D NEWLINE
+ . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1
+ . S TEXT=INDSTR_WORD,CLEN=LENWORD
+ E  D
+ . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1
+ . S TEXT=TEXT_WORD,CLEN=CLEN+LENWORD
+ Q
+ ;
+ ;================================================================
+FORMAT(LM,RM,NIN,TEXTIN,NOUT,TEXTOUT) ;Format the text in TEXTIN so it has
+ ;a left margin of LM and a right margin of RM. The formatted text
+ ;is in TEXTOUT. "\\" is the end of line marker. Lines ending with
+ ;"\\" will not have anything appended to them. A blank line can
+ ;be created by creating a line containing just "\\". Lines containing
+ ;nothing but whitespace will also act like a "\\".
+ I NIN=0 S NOUT=0 Q
+ N ACHAR,ALLWSP,CHAR,CLEN,END,IND,INDENT,INDSTR,JND
+ N LWSP,NWSP,START,TEMP,TEXT,TLEN,WIDTH,W1,W2,WORD
+ ;Catalog the whitespace so we have places to break and look for
+ ;end of line markers.
+ F IND=1:1:NIN D
+ . S TEMP=TEXTIN(IND)
+ . S TLEN=$L(TEMP)
+ . S ALLWSP=1,NWSP=0
+ . F JND=1:1:TLEN D
+ .. S CHAR=$E(TEMP,JND)
+ .. S ACHAR=$A(CHAR)
+ .. I ACHAR>32 S ALLWSP=0
+ .. E  S NWSP=NWSP+1,LWSP(IND,NWSP)=JND
+ .;Mark the end of the line.
+ . S NWSP=NWSP+1,LWSP(IND,NWSP)=TLEN,LWSP(IND)=NWSP
+ . I ALLWSP S LWSP(IND,"ALLWSP")=""
+ I LM<1 S LM=1
+ S WIDTH=RM-LM+1
+ S INDENT=LM-1
+ S INDSTR=""
+ F IND=1:1:INDENT S INDSTR=INDSTR_" "
+ S NOUT=0
+ S TEXT=INDSTR,CLEN=0
+ F IND=1:1:NIN D
+ .;If there is a blank line force whatever is in TEXT to be output by
+ .;calling NEWLINE and then add the blank.
+ . I $D(LWSP(IND,"ALLWSP")) D NEWLINE,BLANK Q
+ . S TEMP=TEXTIN(IND)
+ . S (END,NWSP)=0
+ . F NWSP=1:1:LWSP(IND) D
+ .. S START=END+1,END=LWSP(IND,NWSP)
+ .. S WORD=$E(TEMP,START,END)
+ .. I WORD["\\" D  Q
+ ... S W1=$P(WORD,"\\",1)
+ ... D CHECKLEN(W1)
+ ... D NEWLINE
+ ... S W2=$P(WORD,"\\",2)
+ ... I W2'="" D CHECKLEN(W2)
+ .. D CHECKLEN(WORD)
+ ;Output the last line.
+ D NEWLINE
+ Q
+ ;
+ ;================================================================
+FORMATS(LM,RM,TEXTLINE,NOUT,TEXTOUT) ;Take a single line of input text
+ ;and format it.
+ N TEXTIN
+ S TEXTIN(1)=TEXTLINE
+ D FORMAT(LM,RM,1,.TEXTIN,.NOUT,.TEXTOUT)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m

@@ -1 @@
-PXRMTMED        ; SLC/PKR/PJH - Edit a reminder term. ;04/18/2007
-        ;;2.0;CLINICAL REMINDERS;**1,4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=======================================================
-        N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y
-GETNAME ;Get the name of the term to edit.
-        K DA,DIC,DLAYGO,DTOUT,DUOUT,Y
-        S DIC="^PXRMD(811.5,"
-        S DIC(0)="AEMQL"
-        S DIC("A")="Select Reminder Term: "
-        S DLAYGO=811.5
-        ;Set the starting place for additions.
-        D SETSTART^PXRMCOPY(DIC)
-        W !
-        D ^DIC
-        I ($D(DTOUT))!($D(DUOUT)) Q
-        I Y=-1 G END
-        S DA=$P(Y,U,1)
-        S CS1=$$FILE^PXRMEXCS(811.5,DA)
-        D EDIT(DIC,DA)
-        I $G(DA)="" G GETNAME
-        S CS2=$$FILE^PXRMEXCS(811.5,DA)
-        I CS2=0 G GETNAME
-        I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
-        G GETNAME
-END     ;
-        Q
-        ;
-        ;=======================================================
-CLASS(DA,DIE)   ;
-        N DR,RESULT,X,Y
-RETRY   W !
-        S DR="100" D ^DIE I $D(Y) Q
-        ;Sponsor
-        S DR="101" D ^DIE I $D(Y) Q
-        ;Make sure Class and Sponsor Class are in synch.
-        S RESULT=$$VSPONSOR^PXRMINTR(X)
-        I RESULT=0 S DIE("NO^")="Other value" G RETRY
-        I RESULT=1 K DIE("NO^")
-        ;Review date, Usage
-        S DR="102;1" D ^DIE I $D(Y) Q
-        Q
-        ;
-        ;=======================================================
-EDIT(ROOT,DA)   ;
-        N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y
-        ;PXRMTMD is set by a xref on the .01 as a flag that the entire
-        ;entry is being deleted.
-        S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1)
-        S DIE=ROOT
-        I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D
-        . S DR=".01"
-        . D ^DIE
-        . I $G(DA)'="" D CLASS(DA,DIE)
-        I $G(DA)="" Q
-        S TCONT=1
-        F  D FINDING(DIE,DA)  Q:TCONT=0
-        Q
-        ;
-        ;=======================================================
-FINDING(DIE,DA,LIST)    ;
-        N CFIEN,GLOB,IEN,LIST,NODE,TERMSTAT,VF,WPIEN
-        N DEF,DEF1,DEF2,STATUS
-        S DIE("NO^")="OUTOK"
-        S STATUS=0
-        D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)
-        S NODE="^PXRMD(811.5)"
-        D LIST^PXRMREDT(NODE,DA,.LIST)
-        D DSPALL^PXRMREDF("T",NODE,DA,.LIST)
-        S DA(1)=DA
-        S IEN=DA
-        S DIC=DIE_DA(1)_",20,"
-        S DIC(0)="QEAL"
-        S DIC("A")="Select Finding: "
-        D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q
-        S DIE=DIC
-        S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
-        I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D
-        . I $D(^PXRMD(811.4,CFIEN,1))>0 D
-        .. W !!,"Computed Finding Description:" S WPIEN=0
-        .. F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
-        ... W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
-        . E  W !!,"No description defined for this computed finding"
-        . W !
-        I GLOB="YTT(601.71," D WARN^PXRMMH
-        W !,"Editing Finding Number: "_$G(DA)
-        ;Finding record fields
-        S DR=".01;9;12;17"
-        I GLOB="PXRMD(811.4," S DR=DR_";26"
-        ;Taxonomy - use inactive problems
-        I GLOB="PXD(811.2," D
-        .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H")
-        .I TERMSTAT="P" S DR=DR_";10" Q
-        .I TERMSTAT'=0 S DR=DR_";10",STATUS=1
-        ;Health Factor - within category rank
-        I GLOB="AUTTHF(" S DR=DR_";11"
-        ;If V file INCLUDE VISIT DATA
-        S VF=$S(GLOB["AUTTEDT":1,GLOB["AUTTEXAM":1,GLOB["AUTTHF":1,GLOB["AUTTIMM":1,GLOB="AUTTSK":1,GLOB["PXD(811.2":1,1:0)
-        I VF S DR=DR_";28"
-        ;Mental Health - scale
-        I GLOB="YTT(601.71," S DR=DR_";13"
-        ;Radiology procedure
-        I GLOB="RAMIS(71," S STATUS=1
-        ;Orderable item
-        I GLOB="ORD(101.43," S DR=DR_";27",STATUS=1
-        ;Rx Type
-        I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16;27",STATUS=1
-        ;Condition
-        S DR=DR_";14;15;18"
-        ;
-        ;Edit finding record
-        D ^DIE
-        I STATUS=1,$D(DA)>0,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"T")
-        S $P(^PXRMD(811.5,IEN,20,0),U,3)=0
-        Q
-        ;
+PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**1,4**;Feb 04, 2005;Build 21
+ ;
+ ;=======================================================
+ N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y
+GETNAME ;Get the name of the term to edit.
+ K DA,DIC,DLAYGO,DTOUT,DUOUT,Y
+ S DIC="^PXRMD(811.5,"
+ S DIC(0)="AEMQL"
+ S DIC("A")="Select Reminder Term: "
+ S DLAYGO=811.5
+ ;Set the starting place for additions.
+ D SETSTART^PXRMCOPY(DIC)
+ W !
+ D ^DIC
+ I ($D(DTOUT))!($D(DUOUT)) Q
+ I Y=-1 G END
+ S DA=$P(Y,U,1)
+ S CS1=$$FILE^PXRMEXCS(811.5,DA)
+ D EDIT(DIC,DA)
+ I $G(DA)="" G GETNAME
+ S CS2=$$FILE^PXRMEXCS(811.5,DA)
+ I CS2=0 G GETNAME
+ I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
+ G GETNAME
+END ;
+ Q
+ ;
+ ;=======================================================
+CLASS(DA,DIE) ;
+ N DR,RESULT,X,Y
+RETRY W !
+ S DR="100" D ^DIE I $D(Y) Q
+ ;Sponsor
+ S DR="101" D ^DIE I $D(Y) Q
+ ;Make sure Class and Sponsor Class are in synch.
+ S RESULT=$$VSPONSOR^PXRMINTR(X)
+ I RESULT=0 S DIE("NO^")="Other value" G RETRY
+ I RESULT=1 K DIE("NO^")
+ ;Review date, Usage
+ S DR="102;1" D ^DIE I $D(Y) Q
+ Q
+ ;
+ ;=======================================================
+EDIT(ROOT,DA) ;
+ N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y
+ ;PXRMTMD is set by a xref on the .01 as a flag that the entire
+ ;entry is being deleted.
+ S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1)
+ S DIE=ROOT
+ I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D
+ . S DR=".01"
+ . D ^DIE
+ . I $G(DA)'="" D CLASS(DA,DIE)
+ I $G(DA)="" Q
+ S TCONT=1
+ F  D FINDING(DIE,DA)  Q:TCONT=0
+ Q
+ ;
+ ;=======================================================
+FINDING(DIE,DA,LIST) ;
+ N CFIEN,GLOB,IEN,LIST,NODE,TERMSTAT,VF,WPIEN
+ N DEF,DEF1,DEF2,STATUS
+ S STATUS=0
+ D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)
+ S NODE="^PXRMD(811.5)"
+ D LIST^PXRMREDT(NODE,DA,.LIST)
+ D DSPALL^PXRMREDF("T",NODE,DA,.LIST)
+ S DA(1)=DA
+ S IEN=DA
+ S DIC=DIE_DA(1)_",20,"
+ S DIC(0)="QEAL"
+ S DIC("A")="Select Finding: "
+ D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q
+ S DIE=DIC
+ S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
+ I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D
+ .I $D(^PXRMD(811.4,CFIEN,1))>0 D
+ ..W !!,"Computed Finding Description:" S WPIEN=0
+ ..F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
+ ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
+ .E  W !!,"No description defined for this computed finding"
+ .W !
+ W !,"Editing Finding Number: "_$G(DA)
+ ;Finding record fields
+ S DR=".01;9;12;17"
+ I GLOB="PXRMD(811.4," S DR=DR_";26"
+ ;Taxonomy - use inactive problems
+ I GLOB="PXD(811.2," D
+ .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H")
+ .I TERMSTAT="P" S DR=DR_";10" Q
+ .I TERMSTAT'=0 S DR=DR_";10",STATUS=1
+ ;Health Factor - within category rank
+ I GLOB="AUTTHF(" S DR=DR_";11"
+ ;If V file INCLUDE VISIT DATA
+ S VF=$S(GLOB["AUTTEDT":1,GLOB["AUTTEXAM":1,GLOB["AUTTHF":1,GLOB["AUTTIMM":1,GLOB="AUTTSK":1,GLOB["PXD(811.2":1,1:0)
+ I VF S DR=DR_";28"
+ ;Mental Health - scale
+ I GLOB="YTT(601," S DR=DR_";13"
+ ;Radiology procedure
+ I GLOB="RAMIS(71," S STATUS=1
+ ;Orderable item
+ I GLOB="ORD(101.43," S DR=DR_";27",STATUS=1
+ ;Rx Type
+ I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16;27",STATUS=1
+ ;Condition
+ S DR=DR_";14;15;18"
+ ;
+ ;Edit finding record
+ D ^DIE
+ I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T")
+ S $P(^PXRMD(811.5,IEN,20,0),U,3)=0
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m

@@ -1 @@
-PXRMUTIL        ; SLC/PKR/PJH - Utility routines for use by PXRM. ;10/02/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=================================
-ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value
-        ;pairs. Each pair is separated by SEP and the attribute value pair
-        ;is separated by AVSEP. Return the value for the attribute ATTR.
-        N AVPAIR,IND,NUMAVP,VALUE
-        S NUMAVP=$L(STRING,SEP)
-        S VALUE=""
-        F IND=1:1:NUMAVP Q:VALUE'=""  D
-        . S AVPAIR=$P(STRING,SEP,IND)
-        . I AVPAIR[ATTR S VALUE=$P(AVPAIR,AVSEP,2)
-        Q VALUE
-        ;
-        ;=================================
-ACOPY(REF,OUTPUT)       ;Copy all the descendants of the array reference into a linear
-        ;array. REF is the starting array reference, for example A or
-        ;^TMP("PXRM",$J). OUTPUT is the linear array for the output. It
-        ;should be in the form of a closed root, i.e., A() or ^TMP($J,).
-        ;Note OUTPUT cannot be used as the name of the output array.
-        N DONE,IND,LEN,NL,OROOT,OUT,PROOT,ROOT,START,TEMP
-        I REF="" Q
-        S NL=0
-        S OROOT=$P(OUTPUT,")",1)
-        S PROOT=$P(REF,")",1)
-        ;Build the root so we can tell when we are done.
-        S TEMP=$NA(@REF)
-        S ROOT=$P(TEMP,")",1)
-        S REF=$Q(@REF)
-        I REF'[ROOT Q
-        S DONE=0
-        F  Q:(REF="")!(DONE)  D
-        . S START=$F(REF,ROOT)
-        . S LEN=$L(REF)
-        . S IND=$E(REF,START,LEN)
-        . S NL=NL+1
-        . S OUT=OROOT_NL_")"
-        . S @OUT=PROOT_IND_"="_@REF
-        . S REF=$Q(@REF)
-        . I REF'[ROOT S DONE=1
-        Q
-        ;
-        ;=================================
-AWRITE(REF)     ;Write all the descendants of the array reference.
-        ;REF is the starting array reference, for example A or ^TMP("PXRM",$J).
-        N DONE,IND,LEN,PROOT,ROOT,START,TEMP
-        I REF="" Q
-        S PROOT=$P(REF,")",1)
-        ;Build the root so we can tell when we are done.
-        S TEMP=$NA(@REF)
-        S ROOT=$P(TEMP,")",1)
-        S REF=$Q(@REF)
-        I REF'[ROOT Q
-        S DONE=0
-        F  Q:(REF="")!(DONE)  D
-        . S START=$F(REF,ROOT)
-        . S LEN=$L(REF)
-        . S IND=$E(REF,START,LEN)
-        . W !,PROOT_IND,"=",@REF
-        . S REF=$Q(@REF)
-        . I REF'[ROOT S DONE=1
-        Q
-        ;
-        ;=================================
-DIP(VAR,IEN,PXRMROOT,FLDS)      ;Do general inquiry for IEN return formatted
-        ;output in VAR. VAR can be either a local variable or a global.
-        ;If it is a local it is indexed for the broker. If it is a global
-        ;it should be passed in closed form i.e., ^TMP("PXRMTEST",$J).
-        ;It will be returned formatted for ListMan i.e.,
-        ;^TMP("PXRMTEST",$J,N,0).
-        N %ZIS,ARRAY,BY,DC,DHD,DIC,DONE,FF,FILENAME,FILESPEC,FR,GBL,HFNAME
-        N IND,IOP,L,NOW,PATH,SUCCESS,TO,UNIQN
-        S BY="NUMBER",(FR,TO)=+$P(IEN,U,1),DHD="@@"
-        ;Make sure the PXRM WORKSTATION device exists.
-        D MKWSDEV^PXRMHOST
-        ;Set up the output file before DIP is called.
-        S PATH=$$PWD^%ZISH
-        S NOW=$$NOW^XLFDT
-        S NOW=$TR(NOW,".","")
-        S UNIQN=$J_NOW
-        S FILENAME="PXRMWSD"_UNIQN_".DAT"
-        S HFNAME=PATH_FILENAME
-        S IOP="PXRM WORKSTATION;80"
-        S %ZIS("HFSMODE")="W"
-        S %ZIS("HFSNAME")=HFNAME
-        S L=0,DIC=PXRMROOT
-        D EN1^DIP
-        ;Move the host file into a global.
-        S GBL="^TMP(""PXRMUTIL"",$J,1,0)"
-        S GBL=$NA(@GBL)
-        K ^TMP("PXRMUTIL",$J)
-        S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3)
-        ;Look for a form feed, remove it and all subsequent lines.
-        S FF=$C(12)
-        I $G(VAR)["^" D
-        . S VAR=$NA(@VAR)
-        . S VAR=$P(VAR,")",1)
-        . S VAR=VAR_",IND,0)"
-        . S (DONE,IND)=0
-        . F  Q:DONE  S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0  D
-        .. I ^TMP("PXRMUTIL",$J,IND,0)=FF S DONE=1 Q
-        .. S @VAR=^TMP("PXRMUTIL",$J,IND,0)
-        E  D
-        . S (DONE,IND)=0
-        . F  Q:DONE  S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0  D
-        .. S VAR(IND)=^TMP("PXRMUTIL",$J,IND,0)
-        .. I VAR(IND)=FF K ARRAY(IND) S DONE=1
-        K ^TMP("PXRMUTIL",$J)
-        ;Delete the host file.
-        S FILESPEC(FILENAME)=""
-        S SUCCESS=$$DEL^%ZISH(PATH,$NA(FILESPEC))
-        Q
-        ;
-        ;=================================
-FNFR(ROOT)      ;Given the root of a file return the file number.
-        Q +$P(@(ROOT_"0)"),U,2)
-        ;
-        ;=================================
-NTOAN(NUMBER)   ;Given an integer N return an alphabetic string that can be
-        ;used for sorting. This will be modulus 26. For example N=0 returns
-        ;A, N=26 returns BA etc.
-        N ALPH
-        S ALPH(0)="A",ALPH(1)="B",ALPH(2)="C",ALPH(3)="D",ALPH(4)="E"
-        S ALPH(5)="F",ALPH(6)="G",ALPH(7)="H",ALPH(8)="I",ALPH(9)="J"
-        S ALPH(10)="K",ALPH(11)="L",ALPH(12)="M",ALPH(13)="N",ALPH(14)="O"
-        S ALPH(15)="P",ALPH(16)="Q",ALPH(17)="R",ALPH(18)="S",ALPH(19)="T"
-        S ALPH(20)="U",ALPH(21)="V",ALPH(22)="W",ALPH(23)="X",ALPH(24)="Y"
-        S ALPH(25)="Z"
-        ;
-        N ANUM,DIGIT,NUM,P26,PC,PWR
-        S ANUM="",NUM=NUMBER,PWR=0
-        S P26(PWR)=1
-        F PWR=1:1 S P26(PWR)=26*P26(PWR-1) I P26(PWR)>NUMBER Q
-        S PWR=PWR-1
-        F PC=PWR:-1:0 D
-        . S DIGIT=NUM\P26(PC)
-        . S ANUM=ANUM_ALPH(DIGIT)
-        . S NUM=NUM-(DIGIT*P26(PC))
-        Q ANUM
-        ;
-        ;=================================
-RMEHIST(FILENUM,IEN)    ;Remove the edit history for a reminder file.
-        I (FILENUM<800)!(FILENUM>811.9)!(FILENUM=811.8) Q
-        N DA,DIK,GLOBAL,ROOT
-        S GLOBAL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
-        ;Edit History is stored in node 110 for all files.
-        S DA(1)=IEN
-        S DIK=GLOBAL_IEN_",110,"
-        S ROOT=GLOBAL_IEN_",110,DA)"
-        S DA=0
-        F  S DA=+$O(@ROOT) Q:DA=0  D ^DIK
-        Q
-        ;
-        ;=================================
-SEHIST(FILENUM,ROOT,IEN)        ;Set the edit date and edit by and prompt the
-        ;user for the edit comment.
-        N DIC,DIR,DWLW,DWPK,ENTRY,FDA,FDAIEN,IENS,IND,MSG,SFN,TARGET,X,Y
-        K ^TMP("PXRMWP",$J)
-        D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
-        S SFN=+$G(TARGET("SPECIFIER"))
-        I SFN=0 Q
-        S ENTRY=ROOT_IEN_",110)"
-        S IND=$O(@ENTRY@("B"),-1)
-        S IND=IND+1
-        S IENS="+"_IND_","_IEN_","
-        S FDAIEN(IEN)=IEN
-        S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
-        S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
-        ;Prompt the user for edit comments.
-        S DIC="^TMP(""PXRMWP"",$J,"
-        S DWLW=72
-        S DWPK=1
-        W !,"Input your edit comments."
-        S DIR(0)="Y"_U_"AO"
-        S DIR("A")="Edit"
-        S DIR("B")="NO"
-        D ^DIR
-        I Y D
-        . D EN^DIWE
-        . K ^TMP("PXRMWP",$J,0)
-        . I $D(^TMP("PXRMWP",$J)) S FDA(SFN,IENS,2)="^TMP(""PXRMWP"",$J)"
-        D UPDATE^DIE("E","FDA","FDAIEN","MSG")
-        I $D(MSG) D AWRITE^PXRMUTIL("MSG")
-        K ^TMP("PXRMWP",$J)
-        Q
-        ;
-        ;=================================
-SFRES(SDIR,NRES,FIEVAL) ;Save the finding result.
-        I NRES=0 S FIEVAL=0 Q
-        N DATE,IND,OA,SUB,TF
-        F IND=1:1:NRES S OA(FIEVAL(IND,"DATE"),FIEVAL(IND),IND)=""
-        ;If SDIR is positive get the oldest date otherwise get the most
-        ;recent date.
-        S DATE=$S(SDIR>0:$O(OA("")),1:$O(OA(""),-1))
-        ;If there is a true finding on DATE get it.
-        S TF=$O(OA(DATE,""),-1)
-        S IND=$O(OA(DATE,TF,""))
-        S FIEVAL=TF
-        S SUB=""
-        F  S SUB=$O(FIEVAL(IND,SUB)) Q:SUB=""  M FIEVAL(SUB)=FIEVAL(IND,SUB)
-        Q
-        ;
-        ;=================================
-SSPAR(FIND0,NOCC,BDT,EDT)       ;Set the finding search parameters.
-        S BDT=$P(FIND0,U,8),EDT=$P(FIND0,U,11),NOCC=$P(FIND0,U,14)
-        I +NOCC=0 S NOCC=1
-        ;Convert the dates to FileMan dates.
-        S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT))
-        I EDT="" S EDT="T"
-        S EDT=$$CTFMD^PXRMDATE(EDT)
-        ;If EDT does not contain a time set it to the end of the day.
-        I EDT'["." S EDT=EDT_".235959"
-        I $G(PXRMDDOC)'=1 Q
-        S ^TMP("PXRMDDOC",$J,$P(FIND0,U,1,11))=BDT_U_EDT
-        Q
-        ;
-        ;=================================
-STRREP(STRING,TS,RS)    ;Replace every occurrence of the target string (TS)
-        ;in STRING with the replacement string (RS).
-        ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
-        ;  F  Q:STRING'[TS  S STRING=$P(STRING,TS)_RS_$P(STRING,TS,2,999)
-        ;fails if any portion of the target string is contained in the with
-        ;string. Therefore a more elaborate version is required.
-        ;
-        N IND,NPCS,STR
-        I STRING'[TS Q STRING
-        ;Count the number of pieces using the target string as the delimiter.
-        S NPCS=$L(STRING,TS)
-        ;Extract the pieces and concatenate RS
-        S STR=""
-        F IND=1:1:NPCS-1 S STR=STR_$P(STRING,TS,IND)_RS
-        S STR=STR_$P(STRING,TS,NPCS)
-        Q STR
-        ;
-        ;=================================
-VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries
-        ;a user can edit.
-        N CLASS,ENTRY,VALID
-        S ENTRY=ROOT_IEN_")"
-        S CLASS=$P($G(@ENTRY@(100)),U,1)
-        I CLASS="N" D
-        . I ($G(PXRMINST)=1),(DUZ(0)="@") S VALID=1
-        . E  S VALID=0
-        E  S VALID=1
-        Q VALID
-        ;
+PXRMUTIL ; SLC/PKR/PJH - Utility routines for use by PXRM. ;05/25/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;===========================================================
+ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value
+ ;pairs. Each pair is separated by SEP and the attribute value pair
+ ;is separated by AVSEP. Return the value for the attribute ATTR.
+ N AVPAIR,IND,NUMAVP,VALUE
+ S NUMAVP=$L(STRING,SEP)
+ S VALUE=""
+ F IND=1:1:NUMAVP Q:VALUE'=""  D
+ . S AVPAIR=$P(STRING,SEP,IND)
+ . I AVPAIR[ATTR S VALUE=$P(AVPAIR,AVSEP,2)
+ Q VALUE
+ ;
+ ;===========================================================
+AWRITE(REF) ;Write all the descendants of the array reference.
+ ;REF is the starting array reference, for example A or ^TMP("PXRM",$J).
+ N DONE,IND,LEN,PROOT,ROOT,START,TEMP
+ I REF="" Q
+ S PROOT=$P(REF,")",1)
+ ;Build the root so we can tell when we are done.
+ S TEMP=$NA(@REF)
+ S ROOT=$P(TEMP,")",1)
+ S REF=$Q(@REF)
+ I REF'[ROOT Q
+ S DONE=0
+ F  Q:(REF="")!(DONE)  D
+ . S START=$F(REF,ROOT)
+ . S LEN=$L(REF)
+ . S IND=$E(REF,START,LEN)
+ . W !,PROOT_IND,"=",@REF
+ . S REF=$Q(@REF)
+ . I REF'[ROOT S DONE=1
+ Q
+ ;
+ ;===========================================================
+DIP(VAR,IEN,PXRMROOT,FLDS) ;Do general inquiry for IEN return formatted
+ ;output in VAR. VAR can be either a local variable or a global.
+ ;If it is a local it is indexed for the broker. If it is a global
+ ;it should be passed in closed form i.e., ^TMP("PXRMTEST",$J).
+ ;It will be returned formatted for ListMan i.e.,
+ ;^TMP("PXRMTEST",$J,N,0).
+ N %ZIS,ARRAY,BY,DC,DHD,DIC,DONE,FF,FILENAME,FILESPEC,FR,GBL,HFNAME
+ N IND,IOP,L,NOW,PATH,SUCCESS,TO,UNIQN
+ S BY="NUMBER",(FR,TO)=+$P(IEN,U,1),DHD="@@"
+ ;Make sure the PXRM WORKSTATION device exists.
+ D MKWSDEV^PXRMHOST
+ ;Set up the output file before DIP is called.
+ S PATH=$$PWD^%ZISH
+ S NOW=$$NOW^XLFDT
+ S NOW=$TR(NOW,".","")
+ S UNIQN=$J_NOW
+ S FILENAME="PXRMWSD"_UNIQN_".DAT"
+ S HFNAME=PATH_FILENAME
+ S IOP="PXRM WORKSTATION;80"
+ S %ZIS("HFSMODE")="W"
+ S %ZIS("HFSNAME")=HFNAME
+ S L=0,DIC=PXRMROOT
+ D EN1^DIP
+ ;Move the host file into a global.
+ S GBL="^TMP(""PXRMUTIL"",$J,1,0)"
+ S GBL=$NA(@GBL)
+ K ^TMP("PXRMUTIL",$J)
+ S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3)
+ ;Look for a form feed, remove it and all subsequent lines.
+ S FF=$C(12)
+ I $G(VAR)["^" D
+ . S VAR=$NA(@VAR)
+ . S VAR=$P(VAR,")",1)
+ . S VAR=VAR_",IND,0)"
+ . S (DONE,IND)=0
+ . F  Q:DONE  S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0  D
+ .. I ^TMP("PXRMUTIL",$J,IND,0)=FF S DONE=1 Q
+ .. S @VAR=^TMP("PXRMUTIL",$J,IND,0)
+ E  D
+ . S (DONE,IND)=0
+ . F  Q:DONE  S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0  D
+ .. S VAR(IND)=^TMP("PXRMUTIL",$J,IND,0)
+ .. I VAR(IND)=FF K ARRAY(IND) S DONE=1
+ K ^TMP("PXRMUTIL",$J)
+ ;Delete the host file.
+ S FILESPEC(FILENAME)=""
+ S SUCCESS=$$DEL^%ZISH(PATH,$NA(FILESPEC))
+ Q
+ ;
+ ;===========================================================
+FNFR(ROOT) ;Given the root of a file return the file number.
+ Q +$P(@(ROOT_"0)"),U,2)
+ ;
+ ;===========================================================
+NTOAN(NUMBER) ;Given an integer N return an alphabetic string that can be
+ ;used for sorting. This will be modulus 26. For example N=0 returns
+ ;A, N=26 returns BA etc.
+ N ALPH
+ S ALPH(0)="A",ALPH(1)="B",ALPH(2)="C",ALPH(3)="D",ALPH(4)="E"
+ S ALPH(5)="F",ALPH(6)="G",ALPH(7)="H",ALPH(8)="I",ALPH(9)="J"
+ S ALPH(10)="K",ALPH(11)="L",ALPH(12)="M",ALPH(13)="N",ALPH(14)="O"
+ S ALPH(15)="P",ALPH(16)="Q",ALPH(17)="R",ALPH(18)="S",ALPH(19)="T"
+ S ALPH(20)="U",ALPH(21)="V",ALPH(22)="W",ALPH(23)="X",ALPH(24)="Y"
+ S ALPH(25)="Z"
+ ;
+ N ANUM,DIGIT,NUM,P26,PC,PWR
+ S ANUM="",NUM=NUMBER,PWR=0
+ S P26(PWR)=1
+ F PWR=1:1 S P26(PWR)=26*P26(PWR-1) I P26(PWR)>NUMBER Q
+ S PWR=PWR-1
+ F PC=PWR:-1:0 D
+ . S DIGIT=NUM\P26(PC)
+ . S ANUM=ANUM_ALPH(DIGIT)
+ . S NUM=NUM-(DIGIT*P26(PC))
+ Q ANUM
+ ;
+ ;===========================================================
+SEHIST(FILENUM,ROOT,IEN) ;Set the edit date and edit by and prompt the
+ ;user for the edit comment.
+ N DIC,DIR,DWLW,DWPK,ENTRY,FDA,FDAIEN,IENS,IND,MSG,SFN,TARGET,X,Y
+ K ^TMP("PXRMWP",$J)
+ D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
+ S SFN=+$G(TARGET("SPECIFIER"))
+ I SFN=0 Q
+ S ENTRY=ROOT_IEN_",110)"
+ S IND=$O(@ENTRY@("B"),-1)
+ S IND=IND+1
+ S IENS="+"_IND_","_IEN_","
+ S FDAIEN(IEN)=IEN
+ S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+ S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
+ ;Prompt the user for edit comments.
+ S DIC="^TMP(""PXRMWP"",$J,"
+ S DWLW=72
+ S DWPK=1
+ W !,"Input your edit comments."
+ S DIR(0)="Y"_U_"AO"
+ S DIR("A")="Edit"
+ S DIR("B")="NO"
+ D ^DIR
+ I Y D
+ . D EN^DIWE
+ . K ^TMP("PXRMWP",$J,0)
+ . I $D(^TMP("PXRMWP",$J)) S FDA(SFN,IENS,2)="^TMP(""PXRMWP"",$J)"
+ D UPDATE^DIE("E","FDA","FDAIEN","MSG")
+ I $D(MSG) D AWRITE^PXRMUTIL("MSG")
+ K ^TMP("PXRMWP",$J)
+ Q
+ ;
+ ;===========================================================
+SFRES(SDIR,NRES,FIEVAL) ;Save the finding result.
+ I NRES=0 S FIEVAL=0 Q
+ N DATE,IND,OA,SUB,TF
+ F IND=1:1:NRES S OA(FIEVAL(IND,"DATE"),FIEVAL(IND),IND)=""
+ ;If SDIR is positive get the oldest date otherwise get the most
+ ;recent date.
+ S DATE=$S(SDIR>0:$O(OA("")),1:$O(OA(""),-1))
+ ;If there is a true finding on DATE get it.
+ S TF=$O(OA(DATE,""),-1)
+ S IND=$O(OA(DATE,TF,""))
+ S FIEVAL=TF
+ S SUB=""
+ F  S SUB=$O(FIEVAL(IND,SUB)) Q:SUB=""  M FIEVAL(SUB)=FIEVAL(IND,SUB)
+ Q
+ ;
+ ;===========================================================
+SSPAR(FIND0,NOCC,BDT,EDT) ;Set the finding search parameters.
+ S BDT=$P(FIND0,U,8),EDT=$P(FIND0,U,11),NOCC=$P(FIND0,U,14)
+ I NOCC="" S NOCC=1
+ ;Convert the dates to FileMan dates.
+ S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT))
+ I EDT="" S EDT="T"
+ S EDT=$$CTFMD^PXRMDATE(EDT)
+ ;If EDT does not contain a time set it to the end of the day.
+ I EDT'["." S EDT=EDT_".235959"
+ Q
+ ;
+ ;===========================================================
+STRREP(STRING,TS,RS) ;Replace every occurrence of the target string (TS)
+ ;in STRING with the replacement string (RS).
+ ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz:
+ ;  F  Q:STRING'[TS  S STRING=$P(STRING,TS)_RS_$P(STRING,TS,2,999)
+ ;fails if any portion of the target string is contained in the with
+ ;string. Therefore a more elaborate version is required.
+ ;
+ N IND,NPCS,STR
+ I STRING'[TS Q STRING
+ ;Count the number of pieces using the target string as the delimiter.
+ S NPCS=$L(STRING,TS)
+ ;Extract the pieces and concatenate RS
+ S STR=""
+ F IND=1:1:NPCS-1 S STR=STR_$P(STRING,TS,IND)_RS
+ S STR=STR_$P(STRING,TS,NPCS)
+ Q STR
+ ;
+ ;===========================================================
+VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries
+ ;a user can edit.
+ N CLASS,ENTRY,VALID
+ S ENTRY=ROOT_IEN_")"
+ S CLASS=$P($G(@ENTRY@(100)),U,1)
+ I CLASS="N" D
+ . I ($G(PXRMINST)=1),(DUZ(0)="@") S VALID=1
+ . E  S VALID=0
+ E  S VALID=1
+ Q VALID
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m

@@ -1 @@
-PXRMVITL        ; SLC/PKR - Handle vitals findings. ;09/20/2007
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;===========================================================
-EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate vital measurement findings.
-        D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL)
-        Q
-        ;
-        ;===========================================================
-EVALPL(FINDPA,ENODE,TERMARR,PLIST)      ;Evaluate vital measurement
-        ;term findings for patient lists.
-        D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
-        Q
-        ;
-        ;===========================================================
-EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL)      ;Evaluate vital measurement
-        ;terms.
-        D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
-        Q
-        ;
-        ;===========================================================
-GETDATA(DAS,FIEVT)      ;Return data for a GMRV Vital Measurement entry.
-        N EM,IND,GMRVDATA,STOP,TEMP,TYPE
-        ;DBIA #3647
-        D EN^GMVPXRM(.GMRVDATA,DAS,"I")
-        I $P(GMRVDATA(1),U,1)=-1 D  Q
-        . S ^TMP("PXRMXMZ",$J,1,0)="Found GMRV entry "_DAS_" in the index, but it does not exist in ^GMR(120.5"
-        . D SEND^PXRMMSG("Bad entry in Vitals index.")
-        S FIEVT("TYPE")=$$EXTERNAL^DILFD(120.5,.03,"",GMRVDATA(3),.EM)
-        ;DBIA #10040
-        S TEMP=$S(+GMRVDATA(5)'=0:^SC(GMRVDATA(5),0),1:"")
-        S FIEVT("HOSPITAL LOCATION")=$P(TEMP,U,1)
-        S FIEVT("LOCATION TYPE")=$P(TEMP,U,3)
-        S STOP=$P(TEMP,U,7)
-        S FIEVT("ENTERED BY")=$P(^VA(200,GMRVDATA(6),0),U,1)
-        S (FIEVT("RATE"),FIEVT("VALUE"))=$P(GMRVDATA(7),U,1)
-        S IND=0
-        ;Load the external form of the qualifiers.
-        F  S IND=$O(GMRVDATA(12,IND)) Q:IND=""  D
-        . S TEMP=$P(GMRVDATA(12,IND),U,1)
-        .;DBIA #4504
-        . I TEMP'="" S FIEVT("QUALIFIER",IND)=$P($G(^GMRD(120.52,+TEMP,0)),U,1)
-        ;DBIA #557
-        I STOP'="" S FIEVT("STOP CODE")=$P(^DIC(40.7,STOP,0),U,1,2)
-        E  S FIEVT("STOP CODE")=""
-        Q
-        ;
-        ;===========================================================
-MHVOUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the MHV output.
-        N DATE,EM,IND,JND,NAME,NOUT,RATE,TEMP,TEXTOUT,TYPE
-        S TYPE=$$EXTERNAL^DILFD(120.5,.03,"",IFIEVAL("TYPE"),.EM)
-        S NAME="Vital Measurement: "_TYPE_" = "
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S RATE=$G(IFIEVAL(IND,"VALUE"))
-        . I RATE="" S RATE="MISSING"
-        . S DATE=IFIEVAL(IND,"DATE")
-        . S TEMP=NAME_RATE_" ("_$$EDATE^PXRMDATE(DATE)_")"
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
-        ;===========================================================
-OUTPUT(INDENT,IFIEVAL,NLINES,TEXT)      ;Produce the clinical
-        ;maintenance output.
-        N DATE,EM,IND,JND,NOUT,RATE,TEMP,TEXTOUT,TYPE
-        S NLINES=NLINES+1
-        S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Vital Measurement: "_IFIEVAL("TYPE")
-        S IND=0
-        F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
-        . S DATE=IFIEVAL(IND,"DATE")
-        . S TEMP=$$EDATE^PXRMDATE(DATE)
-        . S RATE=$G(IFIEVAL(IND,"VALUE"))
-        . I RATE="" S RATE="MISSING"
-        . S TEMP=TEMP_"; rate - "_RATE
-        . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        .;If there are qualifiers display them.
-        . I $D(IFIEVAL(IND,"QUALIFIER")) D
-        .. S TEMP="Qualifiers:"
-        .. N QIND S QIND=0
-        .. S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) S TEMP=TEMP_" "_IFIEVAL(IND,"QUALIFIER",QIND)
-        .. F  S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) Q:QIND=""  S TEMP=TEMP_", "_IFIEVAL(IND,"QUALIFIER",QIND)
-        .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
-        .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        S NLINES=NLINES+1,TEXT(NLINES)=""
-        Q
-        ;
+PXRMVITL ; SLC/PKR - Handle vitals findings. ;10/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;===========================================================
+EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate vital measurement findings.
+ D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL)
+ Q
+ ;
+ ;===========================================================
+EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate vital measurement
+ ;term findings for patient lists.
+ D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
+ Q
+ ;
+ ;===========================================================
+EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate vital measurement
+ ;terms.
+ D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
+ Q
+ ;
+ ;===========================================================
+GETDATA(DAS,FIEVT) ;Return the value, which is Rate, for a specified
+ ;GMRV Vital Measurement entry.
+ N IND,GMRVDATA,TEMP
+ ;DBIA #3647
+ D EN^GMVPXRM(.GMRVDATA,DAS,"I")
+ I $P(GMRVDATA(1),U,1)=-1 D  Q
+ . S ^TMP("PXRMXMZ",$J,1,0)="Found GMRV entry "_DAS_" in the index, but it does not exist in ^GMRV(120.5"
+ . D SEND^PXRMMSG("Bad entry in Vitals index.")
+ S FIEVT("TYPE")=$P(GMRVDATA(3),U,1)
+ S (FIEVT("RATE"),FIEVT("VALUE"))=$P(GMRVDATA(7),U,1)
+ S IND=0
+ ;Load the external form of the qualifiers.
+ F  S IND=$O(GMRVDATA(12,IND)) Q:IND=""  D
+ . S TEMP=$P(GMRVDATA(12,IND),U,1)
+ .;DBIA #4504
+ . I TEMP'="" S FIEVT("QUALIFIER",IND)=$P($G(^GMRD(120.52,+TEMP,0)),U,1)
+ Q
+ ;
+ ;===========================================================
+MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+ N DATE,EM,IND,JND,NAME,NOUT,RATE,TEMP,TEXTOUT,TYPE
+ S TYPE=$$EXTERNAL^DILFD(120.5,.03,"",IFIEVAL("TYPE"),.EM)
+ S NAME="Vital Measurement: "_TYPE_" = "
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S RATE=$G(IFIEVAL(IND,"VALUE"))
+ . I RATE="" S RATE="MISSING"
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S TEMP=NAME_RATE_" ("_$$EDATE^PXRMDATE(DATE)_")"
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;
+ ;===========================================================
+OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+ ;maintenance output.
+ N DATE,EM,IND,JND,NOUT,RATE,TEMP,TEXTOUT,TYPE
+ S TYPE=$$EXTERNAL^DILFD(120.5,.03,"",IFIEVAL("TYPE"),.EM)
+ S NLINES=NLINES+1
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Vital Measurement: "_TYPE
+ S IND=0
+ F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S TEMP=$$EDATE^PXRMDATE(DATE)
+ . S RATE=$G(IFIEVAL(IND,"VALUE"))
+ . I RATE="" S RATE="MISSING"
+ . S TEMP=TEMP_"; rate - "_RATE
+ . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ .;If there are qualifiers display them.
+ . I $D(IFIEVAL(IND,"QUALIFIER")) D
+ .. S TEMP="Qualifiers:"
+ .. N QIND S QIND=0
+ .. S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) S TEMP=TEMP_" "_IFIEVAL(IND,"QUALIFIER",QIND)
+ .. F  S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) Q:QIND=""  S TEMP=TEMP_", "_IFIEVAL(IND,"QUALIFIER",QIND)
+ .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
+ .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ S NLINES=NLINES+1,TEXT(NLINES)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m

@@ -1 @@
-PXRMVPTR        ; SLC/PKR - Routines for dealing with variable pointers. ; 02/06/2001
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ;
-        ;==================================================
-BLDALIST(FILE,FIELD,LIST)       ;Build a list of variable pointer information
-        ;indexed by the abbreviation.
-        N ABBR,FN,IND,ROOT,TEMP
-        S IND=0
-        F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D
-        . S TEMP=^DD(FILE,FIELD,"V",IND,0)
-        . S FN=$P(TEMP,U,1)
-        . S ROOT=$$ROOT^DILFD(FN)
-        . S ROOT=$P(ROOT,"^",2)
-        . S ABBR=$P(TEMP,U,4)
-        . S LIST(ABBR)=TEMP
-        Q
-        ;
-        ;==================================================
-BLDNLIST(FILE,FIELD,LIST)       ;Build a list of variable pointer information
-        ;indexed by the file number.
-        N FN,IND,ROOT,TEMP
-        ;DBIA #2991
-        S IND=0
-        F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D
-        . S TEMP=^DD(FILE,FIELD,"V",IND,0)
-        . S FN=$P(TEMP,U,1)
-        . S ROOT=$$ROOT^DILFD(FN)
-        . S ROOT=$P(ROOT,"^",2)
-        . S LIST(FN)=TEMP
-        Q
-        ;
-        ;==================================================
-BLDRLIST(FILE,FIELD,LIST)       ;Build a list of variable pointer information
-        ;indexed by the root.
-        N FN,IND,ROOT,TEMP
-        S IND=0
-        F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D
-        . S TEMP=^DD(FILE,FIELD,"V",IND,0)
-        . S FN=$P(TEMP,U,1)
-        . S ROOT=$$ROOT^DILFD(FN)
-        . S ROOT=$P(ROOT,"^",2)
-        . S LIST(ROOT)=TEMP
-        Q
-        ;
+PXRMVPTR ; SLC/PKR - Routines for dealing with variable pointers. ; 02/06/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;==================================================
+BLDALIST(FILE,FIELD,LIST) ;Build a list of variable pointer information
+ ;indexed by the abbreviation.
+ N ABBR,FN,IND,ROOT,TEMP
+ S IND=0
+ F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D
+ . S TEMP=^DD(FILE,FIELD,"V",IND,0)
+ . S FN=$P(TEMP,U,1)
+ . S ROOT=$$ROOT^DILFD(FN)
+ . S ROOT=$P(ROOT,"^",2)
+ . S ABBR=$P(TEMP,U,4)
+ . S LIST(ABBR)=TEMP
+ Q
+ ;
+ ;==================================================
+BLDNLIST(FILE,FIELD,LIST) ;Build a list of variable pointer information
+ ;indexed by the file number.
+ N FN,IND,ROOT,TEMP
+ S IND=0
+ F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D
+ . S TEMP=^DD(FILE,FIELD,"V",IND,0)
+ . S FN=$P(TEMP,U,1)
+ . S ROOT=$$ROOT^DILFD(FN)
+ . S ROOT=$P(ROOT,"^",2)
+ . S LIST(FN)=TEMP
+ Q
+ ;
+ ;==================================================
+BLDRLIST(FILE,FIELD,LIST) ;Build a list of variable pointer information
+ ;indexed by the root.
+ N FN,IND,ROOT,TEMP
+ S IND=0
+ F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D
+ . S TEMP=^DD(FILE,FIELD,"V",IND,0)
+ . S FN=$P(TEMP,U,1)
+ . S ROOT=$$ROOT^DILFD(FN)
+ . S ROOT=$P(ROOT,"^",2)
+ . S LIST(ROOT)=TEMP
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m

@@ -1 @@
-PXRMVSIT        ; SLC/PKR - Visit related info for reminders. ;02/22/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;======================================================
-GETDATA(DA,DATA,SVALUE) ;Return data for a specific Visit file entry.
-        ;DBIA #2028 for Visit file.
-        N DONE,IEN,HTEMP,LOE,TEMP
-        S TEMP=^AUPNVSIT(DA,0)
-        S DATA("VISIT")=DA
-        S DATA("DATE VISIT CREATED")=$P(TEMP,U,2)
-        S DATA("DFN")=$P(TEMP,U,5)
-        S (DATA("LOC. OF ENCOUNTER"),LOE)=$P(TEMP,U,6)
-        ;DBIA #10090
-        S DATA("STATION NUMBER")=$$GET1^DIQ(4,LOE,99)
-        S DATA("OFFICAL VA NAME")=$$GET1^DIQ(4,LOE,100)
-        S DATA("SERVICE CATEGORY")=$P(TEMP,U,7)
-        I $G(SVALUE) S DATA("VALUE")=$P(TEMP,U,7)
-        S DATA("HOSPITAL LOCATION")=$P(TEMP,U,22)
-        ;DBIA #10040, #2804
-        I $G(DATA("HOSPITAL LOCATION"))="" S HTEMP=""
-        E  S HTEMP=^SC(DATA("HOSPITAL LOCATION"),0)
-        S DATA("HLOC")=$P(HTEMP,U,1)
-        S DATA("DSS ID")=$P(TEMP,U,8)
-        I DATA("DSS ID")="" S DATA("DSS ID")=$P(HTEMP,U,7)
-        ;DBIA #557
-        I DATA("DSS ID")'="" S DATA("STOP CODE")=$P(^DIC(40.7,DATA("DSS ID"),0),U,2)
-        S DATA("OUTSIDE LOCATION")=$G(^AUPNVSIT(DA,21))
-        S DATA("COMMENTS")=$G(^AUPNVSIT(DA,811))
-        ;DBIA #4850
-        S DATA("STATUS")=$$STATUS^SDPCE(DA)
-        ;Get the primary provider.
-        ;DBIA #3455 for V PROVIDER
-        S DATA("PRIMARY PROVIDER")="",IEN="",DONE=0
-        F  S IEN=$O(^AUPNVPRV("AD",DA,IEN)) Q:(DONE)!(IEN="")  D
-        . S TEMP=^AUPNVPRV(IEN,0)
-        . I $P(TEMP,U,4)="P" S DATA("PRIMARY PROVIDER")=$P(TEMP,U,1),DONE=1
-        Q
-        ;
-        ;======================================================
-GAPSTAT(VIEN)   ;Return the status of the appointment associated with the
-        ;visit.
-        ;DBIA #4850
-        Q $$STATUS^SDPCE(VIEN)
-        ;
-        ;======================================================
-HENC(VIEN,INDENT,NLINES,TEXT)   ;Display location and comment for historical
-        ;encounters associated with the V files.
-        N COMMENT,HLOC,LOCATION,OLOC,NIN,TEXTIN,VDATA
-        D GETDATA(VIEN,.VDATA) I VDATA("SERVICE CATEGORY")'="E" Q
-        S NIN=0
-        S LOCATION=VDATA("LOC. OF ENCOUNTER")
-        I LOCATION'="" D
-        . S LOCATION=$$GET1^DIQ(4,LOCATION,.01)_" "_$$GET1^DIQ(4,LOCATION,99)
-        . S NIN=NIN+1,TEXTIN(NIN)="Location of Encounter: "_LOCATION_"\\"
-        S HLOC=VDATA("HOSPITAL LOCATION")
-        I HLOC'="" D
-        . S HLOC=$$GET1^DIQ(44,HLOC,.01)
-        . S NIN=NIN+1,TEXTIN(NIN)="Hospital Location: "_HLOC_"\\"
-        S OLOC=VDATA("OUTSIDE LOCATION")
-        I OLOC'="" D
-        . S NIN=NIN+1,TEXTIN(NIN)="Outside Location: "_OLOC_"\\"
-        S COMMENT=VDATA("COMMENT")
-        I COMMENT'="" D
-        . S NIN=NIN+1,TEXTIN(NIN)="Comment: "_COMMENT
-        I NIN>0 D
-        . N JND,NOUT,TEXTOUT
-        . S NLINES=NLINES+1
-        . S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Historical Encounter Information:"
-        . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
-        . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
-        Q
-        ;
-        ;======================================================
-ISHIST(VIEN)    ;Return true if the encounter was historical.
-        ;DBIA #2028
-        I $P($G(^AUPNVSIT(VIEN,0)),U,7)="E" Q 1
-        Q 0
-        ;
-        ;======================================================
-VAPSTAT(VIEN)   ;Return true if the appointment associated with
-        ;the visit has a valid appointment status.
-        ;Return false if the status is one of the following:
-        ;CANCELLED BY CLINIC
-        ;CANCELLED BY CLINIC & AUTO RE-BOOK
-        ;CANCELLED BY PATIENT
-        ;CANCELLED BY PATIENT & AUTO-REBOOK
-        ;DELETED
-        ;NO ACTION TAKEN
-        ;NO-SHOW
-        ;NO-SHOW & AUTO RE-BOOK
-        ;NULL
-        N STATUS,VALID
-        ;DBIA #4850
-        S STATUS=$P($$STATUS^SDPCE(VIEN),U,2)
-        S VALID=$S(STATUS["CANCELLED":0,STATUS["DELETED":0,STATUS["NO ACTION":0,STATUS["NO-SHOW":0,STATUS="":0,1:1)
-        Q VALID
-        ;
+PXRMVSIT ; SLC/PKR - Visit related info for reminders. ;07/06/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;======================================================
+GETDATA(DA,FIEVT,SVALUE) ;Return data for a specific Visit file entry.
+ ;DBIA #2028 for Visit file.
+ N HTEMP,TEMP
+ S TEMP=^AUPNVSIT(DA,0)
+ S FIEVT("VISIT")=DA
+ S FIEVT("DATE VISIT CREATED")=$P(TEMP,U,2)
+ S FIEVT("DFN")=$P(TEMP,U,5)
+ S FIEVT("LOC. OF ENCOUNTER")=$P(TEMP,U,6)
+ S FIEVT("SERVICE CATEGORY")=$P(TEMP,U,7)
+ I $G(SVALUE) S FIEVT("VALUE")=$P(TEMP,U,7)
+ S FIEVT("HOSPITAL LOCATION")=$P(TEMP,U,22)
+ ;DBIA #10040, #2804
+ I $G(FIEVT("HOSPITAL LOCATION"))="" S HTEMP=""
+ E  S HTEMP=^SC(FIEVT("HOSPITAL LOCATION"),0)
+ S FIEVT("HLOC")=$P(HTEMP,U,1)
+ S FIEVT("DSS ID")=$P(TEMP,U,8)
+ I FIEVT("DSS ID")="" S FIEVT("DSS ID")=$P(HTEMP,U,7)
+ ;DBIA #557
+ I FIEVT("DSS ID")'="" S FIEVT("STOP CODE")=$P(^DIC(40.7,FIEVT("DSS ID"),0),U,2)
+ S FIEVT("OUTSIDE LOCATION")=$G(^AUPNVSIT(DA,21))
+ S FIEVT("COMMENTS")=$G(^AUPNVSIT(DA,811))
+ ;DBIA #4850
+ S FIEVT("STATUS")=$$STATUS^SDPCE(DA)
+ Q
+ ;
+ ;======================================================
+GAPSTAT(VIEN) ;Return the status of the appointment associated with the
+ ;visit.
+ ;DBIA #4850
+ Q $$STATUS^SDPCE(VIEN)
+ ;
+ ;======================================================
+HENC(VIEN,INDENT,NLINES,TEXT) ;Display location and comment for historical
+ ;encounters associated with the V files.
+ N COMMENT,HLOC,LOCATION,OLOC,NIN,TEXTIN,VDATA
+ D GETDATA(VIEN,.VDATA) I VDATA("SERVICE CATEGORY")'="E" Q
+ S NIN=0
+ S LOCATION=VDATA("LOC. OF ENCOUNTER")
+ I LOCATION'="" D
+ . S LOCATION=$$GET1^DIQ(4,LOCATION,.01)_" "_$$GET1^DIQ(4,LOCATION,99)
+ . S NIN=NIN+1,TEXTIN(NIN)="Location of Encounter: "_LOCATION_"\\"
+ S HLOC=VDATA("HOSPITAL LOCATION")
+ I HLOC'="" D
+ . S HLOC=$$GET1^DIQ(44,HLOC,.01)
+ . S NIN=NIN+1,TEXTIN(NIN)="Hospital Location: "_HLOC_"\\"
+ S OLOC=VDATA("OUTSIDE LOCATION")
+ I OLOC'="" D
+ . S NIN=NIN+1,TEXTIN(NIN)="Outside Location: "_OLOC_"\\"
+ S COMMENT=VDATA("COMMENT")
+ I COMMENT'="" D
+ . S NIN=NIN+1,TEXTIN(NIN)="Comment: "_COMMENT
+ I NIN>0 D
+ . N JND,NOUT,TEXTOUT
+ . S NLINES=NLINES+1
+ . S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Historical Encounter Information:"
+ . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
+ . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
+ Q
+ ;
+ ;======================================================
+ISHIST(VIEN) ;Return true if the encounter was historical.
+ ;DBIA #2028
+ I $P($G(^AUPNVSIT(VIEN,0)),U,7)="E" Q 1
+ Q 0
+ ;
+ ;======================================================
+VAPSTAT(VIEN) ;Return true if the appointment associated with
+ ;the visit has a valid appointment status.
+ ;Return false if the status is one of the following:
+ ;CANCELLED BY CLINIC
+ ;CANCELLED BY CLINIC & AUTO RE-BOOK
+ ;CANCELLED BY PATIENT
+ ;CANCELLED BY PATIENT & AUTO-REBOOK
+ ;DELETED
+ ;NO ACTION TAKEN
+ ;NO-SHOW
+ ;NO-SHOW & AUTO RE-BOOK
+ N STATUS,VALID
+ ;DBIA #4850
+ S STATUS=$P($$STATUS^SDPCE(VIEN),U,2)
+ S VALID=$S(STATUS["CANCELLED":0,STATUS["DELETED":0,STATUS["NO ACTION":0,STATUS["NO-SHOW":0,1:1)
+ Q VALID
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m

@@ -1 @@
-PXRMXD  ; SLC/PJH - Reminder Due reports DRIVER ;11/27/2006
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-START   ; Arrays and strings
-        N PXRMIOD,PXRMXST,PXRMOPT,PXRMQUE,PXRMXTMP,PXRMSEL
-        N PXRMFAC,PXRMFACN,PXRMSCAT,PXRMSRT,PXRMTYP
-        N REMINDER,PXRMINP,PXRMFCMB,PXRMLCMB,PXRMTCMB,PXRMTOT
-        ; Addenda
-        N PXRMOTM,PXRMPAT,PXRMPCM,PXRMPRV,PXRMTMP,PXRMRCAT,PXRMREM
-        N PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMLCSC,PXRMCGRP,PXRMCGRN
-        N PXRMLIS
-        ; Counters
-        N NCAT,NFAC,NLOC,NPAT,NPCM,NOTM,NPRV,NREM,NCS,NHL,NCGRP
-        ; Flags and Dates
-        N PXRMFD,PXRMSDT,PXRMBDT,PXRMEDT,PXRMREP,PXRMPRIM,PXRMFUT,PXRMDLOC
-        N PXRMRT,PXRMSSN,PXRMTABC,PXRMTABS,PXRMTMP,TITLE,VALUE
-        N DBDOWN,DBDUZ,DBERR,PXRMLIST,PXRMLIS1,Y
-        N PLISTPUG
-        N PXRMTPAT,PXRMDPAT,PXRMPML
-        ;
-        S PXRMRT="PXRMX",PXRMTYP="X",PXRMFCMB="N",PXRMLCMB="N",PXRMTCMB="N"
-        ;
-        I '$D(PXRMUSER) N PXRMUSER S PXRMUSER=0
-        ;
-        ;Guarantee the timestamp is unique.
-        H 1
-        S PXRMXST=$$NOW^XLFDT
-        S PXRMXTMP=PXRMRT_PXRMXST
-        S ^XTMP(PXRMXTMP,0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"PXRM Reminder Due Report"
-        ;
-        ;Check for existing report templates
-REP     ;
-        S PXRMINP=0
-        D:PXRMUSER ^PXRMXTB D:'PXRMUSER ^PXRMXT I $D(DTOUT)!$D(DUOUT) G EXIT
-        ;Run report from template details
-        I PXRMTMP'="" D  G:$D(DUOUT)&'$D(DTOUT) REP Q
-        .D START^PXRMXTA("JOB^PXRMXQUE") K DUOUT,DIRUT,DTOUT
-        ;
-        ;Select sample criteria
-SEL     ;
-        D SELECT^PXRMXSD(.PXRMSEL) I $D(DTOUT) G EXIT
-        I $D(DUOUT) G:PXRMTMP="" EXIT G REP
-        ;
-FAC     ;Get the facility list.
-        I "IRPO"'[PXRMSEL D  G:$D(DTOUT) EXIT G:$D(DUOUT) SEL
-        .D FACILITY^PXRMXSU(.PXRMFAC) Q:$D(DTOUT)!$D(DUOUT)
-        ;
-        ;Check if combined facility report is required
-COMB    I "IRPO"'[PXRMSEL,NFAC>1 D  G:$D(DTOUT) EXIT G:$D(DUOUT) FAC
-        .D COMB^PXRMXSD(.PXRMFCMB,"Facilities","N")
-        ;
-OPT     ;Variable prompts
-        ;
-        ;Get Individual Patient list
-        I PXRMSEL="I" K PXRMPAT D PAT^PXRMXSU(.PXRMPAT)
-        ;Get Patient list #810.5
-        I PXRMSEL="R" K PXRMLIST D LIST^PXRMXSU(.PXRMLIST)
-        ;Get OE/RRteam list
-        I PXRMSEL="O" K PXRMOTM D OERR^PXRMXSU(.PXRMOTM)
-        ;Get PCMM team
-        I PXRMSEL="T" K PXRMPCM D PCMM^PXRMXSU(.PXRMPCM)
-        ;Get provider list
-        I PXRMSEL="P" K PXRMPRV D PROV^PXRMXSU(.PXRMPRV)
-        ;Get the location list.
-        I PXRMSEL="L" K PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMCGRP,PXRMCGRN D
-        .D LOC^PXRMXSU("Determine encounter counts for","HS")
-        I $D(DTOUT) G EXIT
-        I $D(DUOUT) G:"IRPO"[PXRMSEL SEL G:NFAC>1 COMB G FAC
-        ;
-        ;Check if inpatient location report
-        S PXRMINP=$$INP
-        ;
-        ; Primary Provider or All (PCMM Provider only)
-PRIME   I PXRMSEL="P" D  G:$D(DTOUT) EXIT G:$D(DUOUT) OPT
-        .D PRIME^PXRMXSD(.PXRMPRIM)
-        ;
-DR      ; Get the date range.
-        S PXRMFD="P"
-        ; No prompt if individual patients selected
-        ; Single dates only if PCMM teams/providers and OE/RR teams selected
-        ; Choice of previous/future date range if location selected
-        ;
-        ; Prior encounters/future appointments (location only)
-PREV    I PXRMSEL="L" D PREV^PXRMXSD(.PXRMFD) G:$D(DTOUT) EXIT G:$D(DUOUT) OPT
-        ; Date range input (location only)
-        I PXRMSEL="L" D  G:$D(DTOUT) EXIT G:$D(DUOUT) PREV
-        .I PXRMFD="P" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ENCOUNTER")
-        .I PXRMFD="F" D FDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"APPOINTMENT")
-        .I PXRMFD="A" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ADMISSION")
-        .I PXRMFD="C" S PXRMBDT=DT,PXRMEDT=DT
-        ; Due Effective Date
-DUE     D SDR^PXRMXDUT(.PXRMSDT) G:$D(DTOUT) EXIT
-        I $D(DUOUT) G:PXRMSEL="L" PREV G OPT
-        ;
-SCAT    ;Get the service categories.
-        I PXRMSEL="L",PXRMFD="P" D
-        .D SCAT^PXRMXSC
-        .I $D(DTOUT)!$D(DUOUT) Q
-        I $D(DTOUT) G EXIT
-        I $D(DUOUT) G DUE
-        ;
-TYP     ;Determine type of report (detail/summary)
-        S PXRMREP="S"
-        D REP^PXRMXSD(.PXRMREP) I $D(DTOUT) G EXIT
-        I $D(DUOUT) G SCAT
-        ;
-        ;Check if combined location report is required
-LCOMB   S NLOC=0
-        I PXRMREP="D",PXRMSEL="L" D  G:$D(DTOUT) EXIT G:$D(DUOUT) TYP
-        .N DEFAULT,TEXT
-        .D NLOC
-        .I NLOC>1 D COMB^PXRMXSD(.PXRMLCMB,TEXT,DEFAULT)
-        ;
-        ;Check if combined OE/RR team report is required
-TCOMB   I PXRMREP="D",PXRMSEL="O",$G(NOTM)>1 D  G:$D(DTOUT) EXIT G:$D(DUOUT) TYP
-        .N DEFAULT,TEXT
-        .S DEFAULT="N",TEXT="OE/RR teams"
-        .D COMB^PXRMXSD(.PXRMTCMB,TEXT,DEFAULT)
-        ;
-FUT     ;For detailed report give option to display future appointments
-        S PXRMFUT="N"
-        I PXRMREP="D",'PXRMINP D  G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(NLOC>1) LCOMB G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G TYP
-        .D FUTURE^PXRMXSD(.PXRMFUT,"Display All Future Appointments: ",5)
-        .I PXRMFUT="Y" D  Q:$D(DTOUT)!$D(DUOUT)
-        ..D FUTURE^PXRMXSD(.PXRMDLOC,"Display Appointment Location: ",15)
-        ;
-SRT     ;For detailed report give option to sort by appointment date
-        S PXRMSRT="N"
-        I PXRMREP="D",("RI"'[PXRMSEL) D  G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(PXRMINP)&(NLOC>1) LCOMB G:PXRMINP TYP G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G FUT
-        .;Option to sort by Bed for inpatients
-        .I PXRMSEL="L",PXRMINP D BED^PXRMXSD(.PXRMSRT) Q
-        .;Otherwise option to sort by appt. date
-        .D SRT^PXRMXSD(.PXRMSRT)
-        ;
-        ;Option to print full SSN
-SSN     I PXRMREP="D" D  G:$D(DTOUT) EXIT I $D(DUOUT) G:"IR"[PXRMSEL FUT G SRT
-        .D SSN^PXRMXSD(.PXRMSSN)
-        ;
-        ;Option to print without totals, with totals or totals only
-TOT     I PXRMREP="S" D  G:$D(DTOUT) EXIT I $D(DUOUT) G TYP
-        .;Default is normal report
-        .S PXRMTOT="I"
-        .;Ignore patient and patient list reports
-        .I "RI"[PXRMSEL Q
-        .;Only prompt if more than one location, team or provider is selected
-        .I PXRMSEL="P",NPRV<2 Q
-        .I "OT"[PXRMSEL,NOTM<2 Q
-        .;Ignore reports for all locations
-        .I PXRMSEL="L",PXRMLCMB="Y" Q
-        .I PXRMSEL="L" N DEFAULT,TEXT D NLOC Q:NLOC<2
-        .;Prompt for options
-        .N LIT1,LIT2,LIT3
-        .D LIT,TOTALS^PXRMXSD(.PXRMTOT,LIT1,LIT2,LIT3)
-        ;
-MLOC        ;Print Locations empty location at the end of the report
-        W !
-        S DIR(0)="Y",DIR("B")="YES",DIR("A")="Print locations with no patients"
-        D ^DIR
-        I Y="^^" G EXIT
-        I Y=U G:PXRMREP="D" SSN G TOT
-        S PXRMPML=Y
-        ;
-        ;Reminder Category/Individual Reminder Selection
-RCAT    ;
-        D RCAT^PXRMXSU(.PXRMRCAT,.PXRMREM) I $D(DTOUT) G EXIT
-        ;I $D(DUOUT) G:PXRMREP="D" SSN G TOT
-        I $D(DUOUT) G MLOC
-        ;
-        ;Create combined reminder list
-        D MERGE^PXRMXS1
-        ;
-SAV     ;Option to create a new report template
-        I PXRMTMP="" D ^PXRMXTU G:$D(DTOUT) EXIT I $D(DUOUT) G RCAT
-        ;
-        ;Option to print delimiter separated output
-TABS    D  G:$D(DTOUT) EXIT I $D(DUOUT) G SAV
-        .D TABS^PXRMXSD(.PXRMTABS)
-        ;Select chracter
-TCHAR   I PXRMTABS="Y" D  G:$D(DTOUT) EXIT G:$D(DUOUT) TABS
-        .S PXRMTABC=$$DELIMSEL^PXRMXSD
-        ;
-DPAT    ;Ask whether to include deceased and test patients.
-        S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list")
-        N PXRMIDOD I PXRMDPAT>0 S PXRMIDOD=1
-        Q:$D(DTOUT)  G:$D(DUOUT) TABS
-TPAT    ;
-        S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
-        Q:$D(DTOUT)  G:$D(DUOUT) DPAT
-PATLIST ;
-        K PATCREAT
-        N PATLST
-        I PXRMSEL'="I"&(PXRMUSER'="Y") D
-        . D ASK(.PATLST,"Save due patients to a patient list: ",3)
-        . I $G(PATLST)="" Q
-        . I $G(PATLST)="N" S PXRMLIS1="" Q
-        . I $G(PATLST)="Y" D
-        ..S PATCREAT="N"
-        ..D ASK(.PATCREAT,"Secure list?: ",3) I $D(DTOUT)!($D(DUOUT)) Q
-        ..K PLISTPUG
-        ..S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5)
-        I $G(PATLST)="" G:$D(DTOUT) EXIT I $D(DUOUT) G TPAT
-        G:$D(DTOUT) EXIT I $D(DUOUT) G PATLIST
-        I $G(PATLST)="Y" S TEXT="Select PATIENT LIST name: " D PLIST^PXRMLCR(.PXRMLIS1,TEXT,"") Q:$D(DUOUT)!$D(DTOUT)
-        ;Determine whether the report should be queued.
-JOB     ;
-        D JOB^PXRMXQUE
-        Q
-        ;
-        ;Option PXRM REMINDERS DUE (USER)
-USER    N PXRMUSER
-        S PXRMUSER=+$G(DUZ)
-        G START
-        ;
-        ;
-EXIT    ;Clean things up.
-        D EXIT^PXRMXGUT
-        Q
-        ;
-        ;Check if inpatient report
-INP()   ;Applies to location reports only
-        I PXRMSEL'="L" Q 0
-        ;For all inpatient locations default is automatic
-        I $P(PXRMLCSC,U)="HAI" Q 1
-        ;For selected locations check if all locations are wards
-        I $P(PXRMLCSC,U)="HS" Q $$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN)
-        ;Otherwise
-        Q 0
-        ;
-        ;Prompt text
-LIT     N LIT
-        S LIT=$S(PXRMSEL="P":"Provider","OT"[PXRMSEL:"Team",1:"Location")
-        I PXRMFCMB="N" D
-        .S LIT1="Individual "_LIT_"s only"
-        .S LIT2="Individual "_LIT_"s plus Totals by Facility"
-        .S LIT3="Totals by Facility only"
-        I PXRMFCMB="Y" D
-        .S LIT1="Individual "_LIT_"s only"
-        .S LIT2="Individual "_LIT_"s plus Overall Total"
-        .S LIT3="Overall Total only"
-        Q
-        ;
-        ;Check if multiple locations
-NLOC    S DEFAULT="N",NLOC=1,TEXT="Locations"
-        I $P(PXRMLCSC,U)["HA" S DEFAULT="Y",NLOC=999
-        I $P(PXRMLCSC,U)="CA" S DEFAULT="Y",NCS=999
-        I $E(PXRMLCSC)="C" S TEXT="Clinic Stops",NLOC=NCS
-        I $E(PXRMLCSC)="G" S TEXT="Clinic Groups",NLOC=NCGRP
-        I $P(PXRMLCSC,U)="HS" S NLOC=NHL S:$$INP TEXT="Inpatient Locations"
-        ;Special coding if more than one facility and location
-        I $P(PXRMLCSC,U)="HS",NFAC>1,NLOC>1 D
-        .N FAC,HLOCIEN,HLNAME,IC,MULT
-        .S IC=0 S:PXRMFCMB="Y" FAC="COMBINED"
-        .;Build list of locations by facility
-        .F  S IC=$O(PXRMLCHL(IC)) Q:'IC  D
-        ..S HLOCIEN=$P(PXRMLCHL(IC),U,2),FAC=$$FACL^PXRMXAP(HLOCIEN) Q:'FAC
-        ..S HLNAME=$P(PXRMLCHL(IC),U) Q:HLNAME=""
-        ..S MULT(FAC,HLNAME)=""
-        .S MULT=0,FAC=0
-        .;Count locations in each facility
-        .F  S FAC=$O(MULT(FAC)) Q:'FAC  D  Q:MULT
-        ..S IC=0,HLNAME=""
-        ..F  S HLNAME=$O(MULT(FAC,HLNAME)) Q:HLNAME=""  S IC=IC+1
-        ..I IC>1 S MULT=1
-        .;If only one location per facility suppress combined location option
-        .I 'MULT S NLOC=1
-        Q
-        ;
-ASK(YESNO,PROMPT,NUM)        ;
-        N X,Y,TEXT
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="YA0"
-        S DIR("A")=PROMPT
-        S DIR("B")="N"
-        S DIR("?")="Enter Y or N. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMLCR("_NUM_")"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        S YESNO=$E(Y(0))
-        Q
-        ;
+PXRMXD ; SLC/PJH - Reminder Due reports DRIVER ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+START ; Arrays and strings
+ N PXRMIOD,PXRMXST,PXRMOPT,PXRMQUE,PXRMXTMP,PXRMSEL
+ N PXRMFAC,PXRMFACN,PXRMSCAT,PXRMSRT,PXRMTYP
+ N REMINDER,PXRMINP,PXRMFCMB,PXRMLCMB,PXRMTCMB,PXRMTOT
+ ; Addenda
+ N PXRMOTM,PXRMPAT,PXRMPCM,PXRMPRV,PXRMTMP,PXRMRCAT,PXRMREM
+ N PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMLCSC,PXRMCGRP,PXRMCGRN
+ N PXRMLIS
+ ; Counters
+ N NCAT,NFAC,NLOC,NPAT,NPCM,NOTM,NPRV,NREM,NCS,NHL,NCGRP
+ ; Flags and Dates
+ N PXRMFD,PXRMSDT,PXRMBDT,PXRMEDT,PXRMREP,PXRMPRIM,PXRMFUT,PXRMDLOC
+ N PXRMRT,PXRMSSN,PXRMTABC,PXRMTABS,PXRMTMP,TITLE,VALUE
+ N DBDOWN,DBDUZ,DBERR,PXRMLIST,PXRMLIS1,Y
+ N PLISTPUG
+ N PXRMTPAT,PXRMDPAT
+ ;
+ S PXRMRT="PXRMX",PXRMTYP="X",PXRMFCMB="N",PXRMLCMB="N",PXRMTCMB="N"
+ ;
+ I '$D(PXRMUSER) N PXRMUSER S PXRMUSER=0
+ ;
+ ;Guarantee the timestamp is unique.
+ H 1
+ S PXRMXST=$$NOW^XLFDT
+ S PXRMXTMP=PXRMRT_PXRMXST
+ S ^XTMP(PXRMXTMP,0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"PXRM Reminder Due Report"
+ ;
+ ;Check for existing report templates
+REP ;
+ S PXRMINP=0
+ D:PXRMUSER ^PXRMXTB D:'PXRMUSER ^PXRMXT I $D(DTOUT)!$D(DUOUT) G EXIT
+ ;Run report from template details
+ I PXRMTMP'="" D  G:$D(DUOUT)&'$D(DTOUT) REP Q
+ .D START^PXRMXTA("JOB^PXRMXQUE") K DUOUT,DIRUT,DTOUT
+ ;
+ ;Select sample criteria
+SEL ;
+ D SELECT^PXRMXSD(.PXRMSEL) I $D(DTOUT) G EXIT
+ I $D(DUOUT) G:PXRMTMP="" EXIT G REP
+ ;
+FAC ;Get the facility list.
+ I "IRPO"'[PXRMSEL D  G:$D(DTOUT) EXIT G:$D(DUOUT) SEL
+ .D FACILITY^PXRMXSU(.PXRMFAC) Q:$D(DTOUT)!$D(DUOUT)
+ ;
+ ;Check if combined facility report is required
+COMB I "IRPO"'[PXRMSEL,NFAC>1 D  G:$D(DTOUT) EXIT G:$D(DUOUT) FAC
+ .D COMB^PXRMXSD(.PXRMFCMB,"Facilities","N")
+ ;
+OPT ;Variable prompts
+ ;
+ ;Get Individual Patient list
+ I PXRMSEL="I" K PXRMPAT D PAT^PXRMXSU(.PXRMPAT)
+ ;Get Patient list #810.5
+ I PXRMSEL="R" K PXRMLIST D LIST^PXRMXSU(.PXRMLIST)
+ ;Get OE/RRteam list
+ I PXRMSEL="O" K PXRMOTM D OERR^PXRMXSU(.PXRMOTM)
+ ;Get PCMM team
+ I PXRMSEL="T" K PXRMPCM D PCMM^PXRMXSU(.PXRMPCM)
+ ;Get provider list
+ I PXRMSEL="P" K PXRMPRV D PROV^PXRMXSU(.PXRMPRV)
+ ;Get the location list.
+ I PXRMSEL="L" K PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMCGRP,PXRMCGRN D
+ .D LOC^PXRMXSU("Determine encounter counts for","HS")
+ I $D(DTOUT) G EXIT
+ I $D(DUOUT) G:"IRPO"[PXRMSEL SEL G:NFAC>1 COMB G FAC
+ ;
+ ;Check if inpatient location report
+ S PXRMINP=$$INP
+ ;
+ ; Primary Provider or All (PCMM Provider only)
+PRIME I PXRMSEL="P" D  G:$D(DTOUT) EXIT G:$D(DUOUT) OPT
+ .D PRIME^PXRMXSD(.PXRMPRIM)
+ ;
+DR ; Get the date range.
+ S PXRMFD="P"
+ ; No prompt if individual patients selected
+ ; Single dates only if PCMM teams/providers and OE/RR teams selected
+ ; Choice of previous/future date range if location selected
+ ;
+ ; Prior encounters/future appointments (location only)
+PREV I PXRMSEL="L" D PREV^PXRMXSD(.PXRMFD) G:$D(DTOUT) EXIT G:$D(DUOUT) OPT
+ ; Date range input (location only)
+ I PXRMSEL="L" D  G:$D(DTOUT) EXIT G:$D(DUOUT) PREV
+ .I PXRMFD="P" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ENCOUNTER")
+ .I PXRMFD="F" D FDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"APPOINTMENT")
+ .I PXRMFD="A" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ADMISSION")
+ .I PXRMFD="C" S PXRMBDT=DT,PXRMEDT=DT
+ ; Due Effective Date
+DUE D SDR^PXRMXDUT(.PXRMSDT) G:$D(DTOUT) EXIT
+ I $D(DUOUT) G:PXRMSEL="L" PREV G OPT
+ ;
+SCAT ;Get the service categories.
+ I PXRMSEL="L",PXRMFD="P" D
+ .D SCAT^PXRMXSC
+ .I $D(DTOUT)!$D(DUOUT) Q
+ I $D(DTOUT) G EXIT
+ I $D(DUOUT) G DUE
+ ;
+TYP ;Determine type of report (detail/summary)
+ S PXRMREP="S"
+ D REP^PXRMXSD(.PXRMREP) I $D(DTOUT) G EXIT
+ I $D(DUOUT) G SCAT
+ ;
+ ;Check if combined location report is required
+LCOMB S NLOC=0
+ I PXRMREP="D",PXRMSEL="L" D  G:$D(DTOUT) EXIT G:$D(DUOUT) TYP
+ .N DEFAULT,TEXT
+ .D NLOC
+ .I NLOC>1 D COMB^PXRMXSD(.PXRMLCMB,TEXT,DEFAULT)
+ ;
+ ;Check if combined OE/RR team report is required
+TCOMB I PXRMREP="D",PXRMSEL="O",$G(NOTM)>1 D  G:$D(DTOUT) EXIT G:$D(DUOUT) TYP
+ .N DEFAULT,TEXT
+ .S DEFAULT="N",TEXT="OE/RR teams"
+ .D COMB^PXRMXSD(.PXRMTCMB,TEXT,DEFAULT)
+ ;
+FUT ;For detailed report give option to display future appointments
+ S PXRMFUT="N"
+ I PXRMREP="D",'PXRMINP D  G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(NLOC>1) LCOMB G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G TYP
+ .D FUTURE^PXRMXSD(.PXRMFUT,"Display All Future Appointments: ",5)
+ .I PXRMFUT="Y" D  Q:$D(DTOUT)!$D(DUOUT)
+ ..D FUTURE^PXRMXSD(.PXRMDLOC,"Display Appointment Location: ",15)
+ ;
+SRT ;For detailed report give option to sort by appointment date
+ S PXRMSRT="N"
+ I PXRMREP="D",("RI"'[PXRMSEL) D  G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(PXRMINP)&(NLOC>1) LCOMB G:PXRMINP TYP G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G FUT
+ .;Option to sort by Bed for inpatients
+ .I PXRMSEL="L",PXRMINP D BED^PXRMXSD(.PXRMSRT) Q
+ .;Otherwise option to sort by appt. date
+ .D SRT^PXRMXSD(.PXRMSRT)
+ ;
+ ;Option to print full SSN
+SSN I PXRMREP="D" D  G:$D(DTOUT) EXIT I $D(DUOUT) G:"IR"[PXRMSEL FUT G SRT
+ .D SSN^PXRMXSD(.PXRMSSN)
+ ;
+ ;Option to print without totals, with totals or totals only
+TOT I PXRMREP="S" D  G:$D(DTOUT) EXIT I $D(DUOUT) G TYP
+ .;Default is normal report
+ .S PXRMTOT="I"
+ .;Ignore patient and patient list reports
+ .I "RI"[PXRMSEL Q
+ .;Only prompt if more than one location, team or provider is selected
+ .I PXRMSEL="P",NPRV<2 Q
+ .I "OT"[PXRMSEL,NOTM<2 Q
+ .;Ignore reports for all locations
+ .I PXRMSEL="L",PXRMLCMB="Y" Q
+ .I PXRMSEL="L" N DEFAULT,TEXT D NLOC Q:NLOC<2
+ .;Prompt for options
+ .N LIT1,LIT2,LIT3
+ .D LIT,TOTALS^PXRMXSD(.PXRMTOT,LIT1,LIT2,LIT3)
+ ;
+ ;Reminder Category/Individual Reminder Selection
+RCAT ;
+ D RCAT^PXRMXSU(.PXRMRCAT,.PXRMREM) I $D(DTOUT) G EXIT
+ I $D(DUOUT) G:PXRMREP="D" SSN G TOT
+ ;
+ ;Create combined reminder list
+ D MERGE^PXRMXS1
+ ;
+SAV ;Option to create a new report template
+ I PXRMTMP="" D ^PXRMXTU G:$D(DTOUT) EXIT I $D(DUOUT) G RCAT
+ ;
+ ;Option to print delimiter separated output
+TABS D  G:$D(DTOUT) EXIT I $D(DUOUT) G SAV
+ .D TABS^PXRMXSD(.PXRMTABS)
+ ;Select chracter
+TCHAR I PXRMTABS="Y" D  G:$D(DTOUT) EXIT G:$D(DUOUT) TABS
+ .S PXRMTABC=$$DELIMSEL^PXRMXSD
+ ;
+DPAT ;Ask whether to include deceased and test patients.
+ S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list")
+ N PXRMIDOD I PXRMDPAT>0 S PXRMIDOD=1
+ Q:$D(DTOUT)  G:$D(DUOUT) TABS
+TPAT ;
+ S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
+ Q:$D(DTOUT)  G:$D(DUOUT) DPAT
+PATLIST ;
+ K PATCREAT
+ N PATLST
+ I PXRMSEL'="I"&(PXRMUSER'="Y") D
+ . D ASK(.PATLST,"Save due patients to a patient list: ",3)
+ . I $G(PATLST)="" Q
+ . I $G(PATLST)="N" S PXRMLIS1="" Q
+ . I $G(PATLST)="Y" D
+ ..S PATCREAT="N"
+ ..D ASK(.PATCREAT,"Secure list?: ",3) I $D(DTOUT)!($D(DUOUT)) Q
+ ..K PLISTPUG
+ ..S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5)
+ I $G(PATLST)="" G:$D(DTOUT) EXIT I $D(DUOUT) G TPAT
+ G:$D(DTOUT) EXIT I $D(DUOUT) G PATLIST
+ I $G(PATLST)="Y" S TEXT="Select PATIENT LIST name: " D PLIST^PXRMLCR(.PXRMLIS1,TEXT,"") Q:$D(DUOUT)!$D(DTOUT)
+ ;Determine whether the report should be queued.
+JOB ;
+ D JOB^PXRMXQUE
+ Q
+ ;
+ ;Option PXRM REMINDERS DUE (USER)
+USER N PXRMUSER
+ S PXRMUSER=+$G(DUZ)
+ G START
+ ;
+ ;
+EXIT ;Clean things up.
+ D EXIT^PXRMXGUT
+ Q
+ ;
+ ;Check if inpatient report
+INP() ;Applies to location reports only
+ I PXRMSEL'="L" Q 0
+ ;For all inpatient locations default is automatic
+ I $P(PXRMLCSC,U)="HAI" Q 1
+ ;For selected locations check if all locations are wards
+ I $P(PXRMLCSC,U)="HS" Q $$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN)
+ ;Otherwise
+ Q 0
+ ;
+ ;Prompt text
+LIT N LIT
+ S LIT=$S(PXRMSEL="P":"Provider","OT"[PXRMSEL:"Team",1:"Location")
+ I PXRMFCMB="N" D
+ .S LIT1="Individual "_LIT_"s only"
+ .S LIT2="Individual "_LIT_"s plus Totals by Facility"
+ .S LIT3="Totals by Facility only"
+ I PXRMFCMB="Y" D
+ .S LIT1="Individual "_LIT_"s only"
+ .S LIT2="Individual "_LIT_"s plus Overall Total"
+ .S LIT3="Overall Total only"
+ Q
+ ;
+ ;Check if multiple locations
+NLOC S DEFAULT="N",NLOC=1,TEXT="Locations"
+ I $P(PXRMLCSC,U)["HA" S DEFAULT="Y",NLOC=999
+ I $P(PXRMLCSC,U)="CA" S DEFAULT="Y",NCS=999
+ I $E(PXRMLCSC)="C" S TEXT="Clinic Stops",NLOC=NCS
+ I $E(PXRMLCSC)="G" S TEXT="Clinic Groups",NLOC=NCGRP
+ I $P(PXRMLCSC,U)="HS" S NLOC=NHL S:$$INP TEXT="Inpatient Locations"
+ ;Special coding if more than one facility and location
+ I $P(PXRMLCSC,U)="HS",NFAC>1,NLOC>1 D
+ .N FAC,HLOCIEN,HLNAME,IC,MULT
+ .S IC=0 S:PXRMFCMB="Y" FAC="COMBINED"
+ .;Build list of locations by facility
+ .F  S IC=$O(PXRMLCHL(IC)) Q:'IC  D
+ ..S HLOCIEN=$P(PXRMLCHL(IC),U,2),FAC=$$FACL^PXRMXAP(HLOCIEN) Q:'FAC
+ ..S HLNAME=$P(PXRMLCHL(IC),U) Q:HLNAME=""
+ ..S MULT(FAC,HLNAME)=""
+ .S MULT=0,FAC=0
+ .;Count locations in each facility
+ .F  S FAC=$O(MULT(FAC)) Q:'FAC  D  Q:MULT
+ ..S IC=0,HLNAME=""
+ ..F  S HLNAME=$O(MULT(FAC,HLNAME)) Q:HLNAME=""  S IC=IC+1
+ ..I IC>1 S MULT=1
+ .;If only one location per facility suppress combined location option
+ .I 'MULT S NLOC=1
+ Q
+ ;
+ASK(YESNO,PROMPT,NUM)      ;
+ N X,Y,TEXT
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="YA0"
+ S DIR("A")=PROMPT
+ S DIR("B")="N"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMLCR("_NUM_")"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ S YESNO=$E(Y(0))
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m

@@ -1 @@
-PXRMXDT1        ; SLC/PJH - Build Patient list SUBROUTINES;08/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ; Called by label from PXRMXSEO,PXRMXSE
-        ;
-        ;Combined report duplicate check (Summary report)
-NEW(SUB,SUB1,SUB2)      ;
-        ;Existing entry
-        I $D(^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)) Q 0
-        ;New entry
-        S ^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)=""
-        Q 1
-        ;
-        ;Individual patient report duplicate patient check
-NEWIP(DFN)      ;
-        ;Existing entry
-        I $D(^TMP("PXRMCMB3",$J,DFN)) Q 0
-        ;New entry
-        S ^TMP("PXRMCMB3",$J,DFN)=""
-        Q 1
-        ;Combined report duplicate check (Detail report)
-NEWP(SUB,DFN)   ;
-        ;Existing entry
-        I $D(^TMP("PXRMCMB1",$J,SUB,DFN)) Q 0
-        ;New entry
-        S ^TMP("PXRMCMB1",$J,SUB,DFN)=""
-        Q 1
-        ;
-        ;Combined report duplicate check (Patient totals)
-NEWT(FACILITY,DFN)      ;
-        ;Existing entry
-        I $D(^TMP("PXRMCMB2",$J,FACILITY,DFN)) Q 0
-        ;New entry
-        S ^TMP("PXRMCMB2",$J,FACILITY,DFN)=""
-        Q 1
-        ;
-        ;Detailed report
-SDET(DFN,STATUS,NAM,FACILITY,INP)       ;
-        I $G(^XTMP(PXRMXTMP,PX,FACILITY,NAM))="" D
-        .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM)=NAM
-        ;Applicable
-        S DDAT="N/A"
-        N APPL,FAPPTDT,DEFARR,DNEXT,DNEXT1,FIEV,PXRMDATE,BID,TMPSUB
-        S APPL=0,FAPPTDT=0
-        ;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total
-        I ($P(STATUS,U)'="")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S APPL=1
-        ;If DUE NOW save details
-        I $G(STATUS)'["DUE NOW" S PNAM=" "
-        I $G(STATUS)["DUE NOW" D
-        .N BED
-        .S DDUE=$P($G(STATUS),U,2)
-        .S DLAST=$P($G(STATUS),U,3)
-        .;Demographics
-        .S PNAM=$P($G(^DPT(DFN,0)),U),BID=$P($G(^DPT(DFN,0)),U,9)
-        .I PNAM="" S PNAM=" "
-        .E  S PNAM=PNAM_U_BID
-        .;Next appointment for location or clinic
-        .;For detailed provider report get next appoint. for assoc. clinic
-        .S DNEXT=""
-        .I PXRMSEL="L"!(PXRMSEL="P") S TMPSUB="PXRM FUTURE APPT"
-        .E  S TMPSUB="SDAMA301"
-        .I PXRMFCMB="Y",PXRMLCMB="Y",$D(^TMP($J,TMPSUB,DFN))>0 D
-        ..N APPTCNT,LOC
-        ..S LOC=0,APPTCNT=0
-        ..F  S LOC=$O(^TMP($J,TMPSUB,DFN,LOC)) Q:(LOC'>0)!(APPTCNT=1)  D
-        ...S DNEXT=$O(^TMP($J,TMPSUB,DFN,LOC,"")) I +DNEXT>0 S APPTCNT=1 Q
-        .S DNEXT=$O(^TMP($J,TMPSUB,DFN,$G(INP),""))
-        .I PXRMFCMB="N",PXRMLCMB="Y" D
-        ..S DNEXT1=$O(^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,"")) Q:DNEXT1'>0
-        ..I +DNEXT=0!(DNEXT>DNEXT1) S DNEXT=DNEXT1
-        .S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE"
-        .;Sort by next appointment date
-        .I PXRMSRT="Y" S DDAT=$P(DNEXT,".") S:DDAT="" DDAT="NONE"
-        .;Patient ward/bed used only for inpatient reports
-        .I PXRMFUT="Y" S DNEXT=""
-        .N TXT
-        .S TXT=DFN_U_DDUE_U_DLAST_U_$G(DNEXT)_$S($G(BED)'="":U_BED,1:"")
-        .I $G(BED)'="",BED'="NONE" S DDAT=BED
-        .N BED
-        .S BED=""
-        .I $G(PXRMINP) D
-        ..S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE"
-        ..S TXT=TXT_U_BED
-        ..;Sort by bed
-        ..I PXRMSRT="B" S DDAT=BED
-        .;Duplicate check for combined report
-        .I PXRMFCMB="Y",'$$NEW(NAM,DDAT,PNAM) Q
-        .;I PXRMFCMB'="Y",PXRMLCMB="Y",'$$NEW^PXRMXSEO(NAM,DDAT,PNAM) Q
-        .;Save entry in ^XTMP
-        .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM)=TXT
-        .;Total of reminders overdue
-        .N CNT
-        .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)=CNT+1
-        ;Total of patients checked/applicable
-        N CNT,NEW
-        S NEW=1 I PXRMFCMB="Y" S NEW=$$NEWP(NAM,DFN)
-        I NEW=1 D
-        .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)=CNT+1
-        .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)=CNT+APPL
-        I PXRMFUT="Y"&($G(STATUS)["DUE NOW") D
-        .N APPTARY,APPTDT,CIEN,CNT,NODE,SUB
-        .S SUB="" I $D(^TMP($J,"PXRM FUTURE APPT",DFN))>0 S SUB="PXRM FUTURE APPT"
-        .I SUB="",$D(^TMP($J,"SDAMA301",DFN))>0 S SUB="SDAMA301"
-        .I SUB="" Q
-        .S CNT=0
-        .S CIEN=0 F  S CIEN=$O(^TMP($J,SUB,DFN,CIEN)) Q:CIEN'>0  D
-        ..S APPTDT=0
-        ..F  S APPTDT=$O(^TMP($J,SUB,DFN,CIEN,APPTDT)) Q:APPTDT'>0  D
-        ...S NODE=$G(^TMP($J,SUB,DFN,CIEN,APPTDT))
-        ...S APPTARY(APPTDT)=APPTDT_U_$P($P(NODE,U,2),";",2)_U_$P($P(NODE,U,22),";",2)
-        .S APPTDT=0 F  S APPTDT=$O(APPTARY(APPTDT)) Q:APPTDT'>0  S CNT=CNT+1,^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM,CNT,0)=APPTARY(APPTDT)
-        Q
-        ;
-SUM(DFN,STATUS,FACILITY,NAM)    ;
-        N DUE,EVAL
-        S (DUE,EVAL)=0
-        ;Add dues to totals of reminders due and reminders applicable
-        I STATUS["DUE NOW" D
-        .S DUE=1,EVAL=1
-        ;Add any that aren't N/A, Ignore on N/A,ERROR or NEVER to applicable total
-        S STATUS=$P(STATUS,U)
-        I (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'="N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S EVAL=1
-        ;Update XTMP - Total of reminders due
-        I "IR"[PXRMTOT D
-        .;Combined facility duplicate check
-        .I PXRMFCMB="Y",'$$NEW(NAM,DFN,ITEM) Q
-        .N CNT
-        .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,1)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,1)=CNT+EVAL
-        .;Total of reminders evaluated
-        .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,2)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,2)=CNT+DUE
-        ;
-        ;Totals
-        I "RT"[PXRMTOT D
-        .;Check for duplicate patient at FACILITY level
-        .I $D(^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)) Q
-        .;Set duplicate check
-        .S ^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)=""
-        .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D
-        ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")="TOTAL"
-        .N CNT
-        .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,1)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,1)=CNT+EVAL
-        .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,2)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,2)=CNT+DUE
-        ;
-        ;Total of patients
-        I "IR"[PXRMTOT D
-        .I PXRMSEL="I",$$NEWIP(DFN)<1 Q
-        .I $$NEWP(@SUB,DFN)=0 Q
-        .I $G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))="" S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM
-        .N CNT S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB)),U,3)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1
-        ;
-        ;Total reports
-        I "TR"[PXRMTOT D
-        .I '$$NEWT(FACILITY,DFN) Q
-        .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D
-        ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")=NAM
-        .N CNT
-        .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")),U,3)
-        .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"),U,3)=CNT+1
-        Q
-        ;
-ERRMSG(TYPE)    ;
-        N CNT,CNT1,CNT2,STR,NLINES,OUTPUT,TIME
-        K ^TMP("PXRMXMZ",$J)
-        S NLINES=0,CNT=0,CNT1=2
-        I TYPE="C" D  Q
-        .M ^TMP("PXRMXMZ",$J)=^TMP($J,"PXRM CNBD")
-        .D SEND^PXRMMSG("REMINDER REPORTS CNBD PATIENT LIST ("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
-        I 'PXRMQUE D
-        .S STR(1)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):"
-        .F  S CNT=$O(DBERR(CNT)) Q:CNT'>0  S STR(CNT1)="\\"_DBERR(CNT),CNT1=CNT1+1
-        .D FORMAT^PXRMTEXT(1,80,2,.STR,.NLINES,.OUTPUT)
-        .F CNT=1:1:NLINES W !,OUTPUT(CNT)
-        I PXRMQUE D
-        .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_"was cancelled for the following reason(s):"
-        .F  S CNT=$O(DBERR(CNT)) Q:CNT'>0  S ^TMP("PXRMXMZ",$J,CNT1,0)=DBERR(CNT),CNT1=CNT1+1
-        .D SEND^PXRMMSG("Cancelled Reminders Due Report ("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
-        .S ZTSTOP=1
-        Q
+PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;07/10/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ; Called by label from PXRMXSEO,PXRMXSE
+ ;
+ ;Combined report duplicate check (Summary report)
+NEW(SUB,SUB1,SUB2) ;
+ ;Existing entry
+ I $D(^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)) Q 0
+ ;New entry
+ S ^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)=""
+ Q 1
+ ;
+ ;Individual patient report duplicate patient check
+NEWIP(DFN) ;
+ ;Existing entry
+ I $D(^TMP("PXRMCMB3",$J,DFN)) Q 0
+ ;New entry
+ S ^TMP("PXRMCMB3",$J,DFN)=""
+ Q 1
+ ;Combined report duplicate check (Detail report)
+NEWP(SUB,DFN) ;
+ ;Existing entry
+ I $D(^TMP("PXRMCMB1",$J,SUB,DFN)) Q 0
+ ;New entry
+ S ^TMP("PXRMCMB1",$J,SUB,DFN)=""
+ Q 1
+ ;
+ ;Combined report duplicate check (Patient totals)
+NEWT(FACILITY,DFN) ;
+ ;Existing entry
+ I $D(^TMP("PXRMCMB2",$J,FACILITY,DFN)) Q 0
+ ;New entry
+ S ^TMP("PXRMCMB2",$J,FACILITY,DFN)=""
+ Q 1
+ ;
+ ;Detailed report
+SDET(DFN,STATUS,NAM,FACILITY,INP) ;
+ I $G(^XTMP(PXRMXTMP,PX,FACILITY,NAM))="" D
+ .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM)=NAM
+ ;Applicable
+ S DDAT="N/A"
+ N APPL,FAPPTDT,DEFARR,DNEXT,DNEXT1,FIEV,PXRMDATE,BID,TMPSUB
+ S APPL=0,FAPPTDT=0
+ ;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total
+ I ($P(STATUS,U)'="")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S APPL=1
+ ;If DUE NOW save details
+ I $G(STATUS)'["DUE NOW" S PNAM=" "
+ I $G(STATUS)["DUE NOW" D
+ .N BED
+ .S DDUE=$P($G(STATUS),U,2)
+ .S DLAST=$P($G(STATUS),U,3)
+ .;Demographics
+ .S PNAM=$P($G(^DPT(DFN,0)),U),BID=$P($G(^DPT(DFN,0)),U,9)
+ .I PNAM="" S PNAM=" "
+ .E  S PNAM=PNAM_U_BID
+ .;Next appointment for location or clinic
+ .;For detailed provider report get next appoint. for assoc. clinic
+ .S DNEXT=""
+ .I PXRMSEL="L"!(PXRMSEL="P") S TMPSUB="PXRM FUTURE APPT"
+ .E  S TMPSUB="SDAMA301"
+ .I PXRMFCMB="Y",PXRMLCMB="Y",$D(^TMP($J,TMPSUB,DFN))>0 D
+ ..N APPTCNT,LOC
+ ..S LOC=0,APPTCNT=0
+ ..F  S LOC=$O(^TMP($J,TMPSUB,DFN,LOC)) Q:(LOC'>0)!(APPTCNT=1)  D
+ ...S DNEXT=$O(^TMP($J,TMPSUB,DFN,LOC,"")) I +DNEXT>0 S APPTCNT=1 Q
+ .S DNEXT=$O(^TMP($J,TMPSUB,DFN,$G(INP),""))
+ .I PXRMFCMB="N",PXRMLCMB="Y" D
+ ..S DNEXT1=$O(^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,"")) Q:DNEXT1'>0
+ ..I +DNEXT=0!(DNEXT>DNEXT1) S DNEXT=DNEXT1
+ .S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE"
+ .;Sort by next appointment date
+ .I PXRMSRT="Y" S DDAT=$P(DNEXT,".") S:DDAT="" DDAT="NONE"
+ .;Patient ward/bed used only for inpatient reports
+ .I PXRMFUT="Y" S DNEXT=""
+ .N TXT
+ .S TXT=DFN_U_DDUE_U_DLAST_U_$G(DNEXT)_$S($G(BED)'="":U_BED,1:"")
+ .I $G(BED)'="",BED'="NONE" S DDAT=BED
+ .N BED
+ .S BED=""
+ .I $G(PXRMINP) D
+ ..S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE"
+ ..S TXT=TXT_U_BED
+ ..;Sort by bed
+ ..I PXRMSRT="B" S DDAT=BED
+ .;Duplicate check for combined report
+ .I PXRMFCMB="Y",'$$NEW(NAM,DDAT,PNAM) Q
+ .;I PXRMFCMB'="Y",PXRMLCMB="Y",'$$NEW^PXRMXSEO(NAM,DDAT,PNAM) Q
+ .;Save entry in ^XTMP
+ .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM)=TXT
+ .;Total of reminders overdue
+ .N CNT
+ .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)=CNT+1
+ ;Total of patients checked/applicable
+ N CNT,NEW
+ S NEW=1 I PXRMFCMB="Y" S NEW=$$NEWP(NAM,DFN)
+ I NEW=1 D
+ .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)=CNT+1
+ .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)=CNT+APPL
+ I PXRMFUT="Y"&($G(STATUS)["DUE NOW") D
+ .N APPTARY,APPTDT,CIEN,CNT,NODE,SUB
+ .S SUB="" I $D(^TMP($J,"PXRM FUTURE APPT",DFN))>0 S SUB="PXRM FUTURE APPT"
+ .I SUB="",$D(^TMP($J,"SDAMA301",DFN))>0 S SUB="SDAMA301"
+ .I SUB="" Q
+ .S CNT=0
+ .S CIEN=0 F  S CIEN=$O(^TMP($J,SUB,DFN,CIEN)) Q:CIEN'>0  D
+ ..S APPTDT=0
+ ..F  S APPTDT=$O(^TMP($J,SUB,DFN,CIEN,APPTDT)) Q:APPTDT'>0  D
+ ...S NODE=$G(^TMP($J,SUB,DFN,CIEN,APPTDT))
+ ...S APPTARY(APPTDT)=APPTDT_U_$P($P(NODE,U,2),";",2)_U_$P($P(NODE,U,22),";",2)
+ .S APPTDT=0 F  S APPTDT=$O(APPTARY(APPTDT)) Q:APPTDT'>0  S CNT=CNT+1,^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM,CNT,0)=APPTARY(APPTDT)
+ Q
+ ;
+SUM(DFN,STATUS,FACILITY,NAM) ;
+ N DUE,EVAL
+ S (DUE,EVAL)=0
+ ;Add dues to totals of reminders due and reminders applicable
+ I STATUS["DUE NOW" D
+ .S DUE=1,EVAL=1
+ ;Add any that aren't N/A, Ignore on N/A,ERROR or NEVER to applicable total
+ S STATUS=$P(STATUS,U)
+ I (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'="N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S EVAL=1
+ ;Update XTMP - Total of reminders due
+ I "IR"[PXRMTOT D
+ .;Combined facility duplicate check
+ .I PXRMFCMB="Y",'$$NEW(NAM,DFN,ITEM) Q
+ .N CNT
+ .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,1)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,1)=CNT+EVAL
+ .;Total of reminders evaluated
+ .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,2)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,2)=CNT+DUE
+ ;
+ ;Totals
+ I "RT"[PXRMTOT D
+ .;Check for duplicate patient at FACILITY level
+ .I $D(^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)) Q
+ .;Set duplicate check
+ .S ^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)=""
+ .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D
+ ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")="TOTAL"
+ .N CNT
+ .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,1)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,1)=CNT+EVAL
+ .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,2)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,2)=CNT+DUE
+ ;
+ ;Total of patients
+ I "IR"[PXRMTOT D
+ .I PXRMSEL="I",$$NEWIP(DFN)<1 Q
+ .I $$NEWP(@SUB,DFN)=0 Q
+ .I $G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))="" S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM
+ .N CNT S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB)),U,3)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1
+ ;
+ ;Total reports
+ I "TR"[PXRMTOT D
+ .I '$$NEWT(FACILITY,DFN) Q
+ .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D
+ ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")=NAM
+ .N CNT
+ .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")),U,3)
+ .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"),U,3)=CNT+1
+ Q
+ ;
+DBDOWN(TYPE) ;
+ N CNT,CNT1,CNT2,STR,NLINES,OUTPUT,TIME
+ K ^TMP("PXRMXMZ",$J)
+ S NLINES=0,CNT=0,CNT1=2
+ I TYPE="C" D  Q
+ .M ^TMP("PXRMXMZ",$J)=^TMP($J,"PXRM CNBD")
+ .D SEND^PXRMMSG("COULD NOT BE DETERMINED PATIENTS("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
+ I 'PXRMQUE D
+ .S STR(1)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):"
+ .F  S CNT=$O(DBERR(CNT)) Q:CNT'>0  S STR(CNT1)="\\"_DBERR(CNT),CNT1=CNT1+1
+ .D FORMAT^PXRMTEXT(1,80,2,.STR,.NLINES,.OUTPUT)
+ .F CNT=1:1:NLINES W !,OUTPUT(CNT)
+ I PXRMQUE D
+ .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):"
+ .F  S CNT=$O(DBERR(CNT)) Q:CNT'>0  S ^TMP("PXRMXMZ",$J,CNT1,0)=DBERR(CNT),CNT1=CNT1+1
+ .D SEND^PXRMMSG("Cancelled Reminders Due Report("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
+ .S ZTSTOP=1
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m

@@ -1 @@
-PXRMXGPR        ; SLC/PJH - Reminder Due print calls ;11/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Called from PXRMXPR
-        ;
-        ;Print Selection criteria
-HEAD(PSTART)    ;
-        I SUB="TOTAL" N NAM S NAM="TOTAL REPORT"
-        I PXRMTABS="Y" D  Q
-        .N FFAC,FNAM
-        .S FNAM=NAM
-        .I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_")
-        .I PXRMFCMB="N","LT"[PXRMSEL D  Q
-        ..S FFAC=$TR(FACPNAME,SEP,"_")
-        ..W !,"0"_SEP_FFAC_"_"_FNAM_SEP_SEP
-        .I PXRMFCMB="N","LT"'[PXRMSEL W !,"0"_SEP_FNAM_SEP_SEP Q
-        .I PXRMFCMB="Y" W !,"0"_SEP_"COMBINED_REPORT_"_FNAM_SEP_SEP Q
-        I "LT"[PXRMSEL D
-        .I PXRMFCMB="N" W !,?PSTART,"Facility: ",FACPNAME Q
-        .W !,?PSTART,"Combined Report: "
-        .N FACN,LENGTH,TEXT
-        .S FACN=0,LENGTH=17+PSTART
-        .F  S FACN=$O(PXRMFACN(FACN)) Q:'FACN  D
-        ..S TEXT=$P(PXRMFACN(FACN),U)_" ("_FACN_")"
-        ..I $O(PXRMFACN(FACN)) S TEXT=TEXT_", "
-        ..I (LENGTH+$L(TEXT))>80 S LENGTH=17+PSTART W !,?(17+PSTART)
-        ..W TEXT S LENGTH=LENGTH+$L(TEXT)
-        I "PTO"[PXRMSEL D
-        .I SUB="TOTAL" W !,?PSTART,NAM Q
-        .W !,?PSTART,"Reminders "_PXRMTX_" for ",NAM
-        I PXRMSEL="L" W !,?PSTART,"Reminders "_PXRMTX_" "_SD_" - ",NAM
-        I PXRMSEL="L" D
-        .I "PF"[PXRMFD W " for ",BD," to ",ED
-        .I PXRMFD="A" W " admissions from ",BD," to ",ED
-        .I PXRMFD="C" W " for current inpatients"
-        I PXRMSEL'="L" W " for ",SD
-        W:PXRMSEL="I" !
-        ;
-        Q
-        ;
-        ;Output the provider report criteria
-CRIT(PSTART,PLSTCRIT)   ;
-        N CNT,RCCNT,RCDES,RICNT,RIDES,UNDL
-        S CNT=0
-        S UNDL=$TR($J("",79)," ","_") D LITS^PXRMXPR1
-        S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART-8)_"Report Criteria:",CNT=CNT+1
-        I PXRMTMP'="" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Report Title:",22)_$P(PXRMTMP,U,3),CNT=CNT+1
-        S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Patient Sample:",22)_PXRMFLD,CNT=CNT+1
-        I PXRMSEL'="L" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22) D DISP(.CNT,.PLSTCRIT)
-        I PXRMSEL="L" D
-        .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22)_DES,CNT=CNT+1
-        .I $E(PXRMLCSC,2)'="A" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",10) D DISP(.CNT,.PLSTCRIT)
-        I $D(PXRMRCAT) D
-        .S RCCNT=0
-        .F  S RCCNT=$O(PXRMRCAT(RCCNT)) Q:'RCCNT  D
-        ..S RCDES=$P(PXRMRCAT(RCCNT),U,2)
-        ..I RCCNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder Category:",22)_RCDES_U_6,CNT=CNT+1
-        ..I RCCNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RCDES
-        .S RICNT=0
-        .F  S RICNT=$O(PXRMREM(RICNT)) Q:'RICNT  D
-        ..S RIDES=$P(PXRMREM(RICNT),U,2)
-        ..I RICNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Individual Reminder:",22)_RIDES_U_6,CNT=CNT+1
-        ..I RICNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RIDES,CNT=CNT+1
-        S PLSTCRIT(CNT)=U_6,CNT=CNT+1
-        I PXRMREP="D" D
-        .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder:",22)_RDES,CNT=CNT+1
-        .;Display future appointments for Reminder Due report only
-        .I PXRMRT="PXRMX" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_"Appointments:" D
-        ..I PXRMFUT="Y" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"All Future Appointments",CNT=CNT+1
-        ..I PXRMFUT="N" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"Next Appointment only",CNT=CNT+1
-        I PXRMSEL="P" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("All/Primary:",22)_CDES,CNT=CNT+1
-        I PXRMSEL="L" D  S CNT=CNT+1
-        .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date Range:",22)
-        .I "PAF"[PXRMFD S PLSTCRIT(CNT)=PLSTCRIT(CNT)_BD_" to "_ED Q
-        .I PXRMFD="C" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_"not applicable" Q
-        S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Effective Due Date:",22)_SD,CNT=CNT+1
-        S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date run:",22)_RD,CNT=CNT+1
-        I PXRMTMP'="" D 
-        .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Template Name:",22)_$P(PXRMTMP,U,2),CNT=CNT+1
-        .I PXRMUSER S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Requested by:",22)_$$GET1^DIQ(200,DUZ,.01)_U_3,CNT=CNT+1
-        I (PXRMFCMB="Y")!(PXRMLCMB="Y")!(PXRMTCMB="Y") D
-        .N LIT,TEXT
-        .S LIT=$S(PXRMSEL="P":"Providers","OT"[PXRMSEL:"Teams",1:"Locations")
-        .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Combined report:",22)
-        .I PXRMFCMB="Y",PXRMLCMB="Y" S TEXT="Combined Facility and Combined "_LIT
-        .I PXRMFCMB="Y",PXRMLCMB="N" S TEXT="Combined Facility by Individual "_LIT
-        .I PXRMLCMB="Y",PXRMFCMB="N" S TEXT="Combined "_LIT
-        .I PXRMTCMB="Y" S TEXT="Combined "_LIT
-        .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        I PXRMREP="S","IRT"[PXRMTOT,"IR"'[PXRMSEL D
-        .N LIT1,LIT2,LIT3,TEXT
-        .D LIT^PXRMXD
-        .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Summary report:",22)
-        .I PXRMTOT="I" S TEXT=LIT1
-        .I PXRMTOT="R" S TEXT=LIT2
-        .I PXRMTOT="T" S TEXT=LIT3
-        .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART,.CNT,.PLSTCRIT)
-        N CHECK,CNT,NODE,STR
-        S CNT=0 F  S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0  D
-        .S NODE=$G(PLSTCRIT(CNT)),CHECK=$P(NODE,U,2),STR=$P(NODE,U)
-        .I CHECK>0 D CHECK(CHECK) I STR="" Q
-        .W !,STR
-        W !,UNDL,!
-        Q
-        ;
-        ;Display selected teams/providers
-DISP(CNT,PLSTCRIT)      ;
-        N IC
-        S IC=""
-        I PXRMSEL="P" F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D
-        .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPRV(IC),U,2),CNT=CNT+1
-        .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPRV(IC),U,2),CNT=CNT+1
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        I PXRMSEL="T" F  S IC=$O(PXRMPCM(IC)) Q:IC=""  D
-        .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPCM(IC),U,2),CNT=CNT+1
-        .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPCM(IC),U,2),CNT=CNT+1
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        I PXRMSEL="O" F  S IC=$O(PXRMOTM(IC)) Q:IC=""  D
-        .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMOTM(IC),U,3),CNT=CNT+1
-        .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMOTM(IC),U,2),CNT=CNT+1
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        I PXRMSEL="I" F  S IC=$O(PXRMPAT(IC)) Q:IC=""  D
-        .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPAT(IC),U,2),CNT=CNT+1
-        .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPAT(IC),U,2),CNT=CNT+1
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        I PXRMSEL="R" F  S IC=$O(PXRMLIST(IC)) Q:IC=""  D
-        .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMLIST(IC),U,2),CNT=CNT+1
-        .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMLIST(IC),U,2),CNT=CNT+1
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        I PXRMSEL="L" D
-        .I $E(PXRMLCSC)="H" F  S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC=""  D
-        ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(^XTMP(PXRMXTMP,"HLOC",IC),U,2),CNT=CNT+1
-        ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        .I $E(PXRMLCSC)="C" F  S IC=$O(PXRMCS(IC)) Q:IC=""  D
-        ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCS(IC),U,1)_" "_$P(PXRMCS(IC),U,3),CNT=CNT+1
-        ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        .I $E(PXRMLCSC)="G" F  S IC=$O(PXRMCGRP(IC)) Q:IC=""  D
-        ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCGRP(IC),U,2),CNT=CNT+1
-        ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        Q
-        ;
-        ;Output the service categories
-OSCAT(SCL,PSTART,CNT,PLSTCRIT)  ;
-        N IC,CSTART,EM,SC,SCTEXT
-        S CSTART=PSTART+3
-        S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Service categories:",22)_SCL,CNT=CNT+1
-        F IC=1:1:$L(SCL,",") D
-        .S SC=$P(SCL,",",IC)
-        .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
-        .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
-        .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",CSTART)_SC_" - "_SCTEXT,CNT=CNT+1
-        Q
-        ;
-        ;If necessary, write the header
-COL(NEWPAGE)    ;
-        I NEWPAGE D  Q:DONE
-        .I PXRMTABS="N" D PAGE
-        .I PXRMTABS="Y" W !!
-        D CHECK(0) Q:DONE
-        D HEAD(0)
-        S HEAD=0
-        I PXRMTABS="Y" Q
-        I PXRMREP="D" D
-        .N PNAM
-        .S PNAM=$P(PXRMREM(1),U,4) I PNAM="" S PNAM=$P(PXRMREM(1),U,2)
-        .W !!,PNAM,":  ",COUNT
-        .W:COUNT>1 " patients have the reminder "_PXRMTX
-        .W:COUNT=1 " patient has the reminder "_PXRMTX
-        N IC F IC=0:1:2 W !,?PXRMT(IC),PXRMH(IC)
-        Q
-        ;
-        ;form feed to new page
-PAGE    I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D
-        .S DIR(0)="E"
-        .W !
-        .D ^DIR K DIR
-        I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
-        W:$D(IOF)&(PAGE>0) @IOF
-        S PAGE=PAGE+1,FIRST=0
-        I $E(IOST,1,2)="C-",IO=IO(0) W @IOF
-        E  W !
-        N TEMP,TEXTLEN
-        S TEMP=$$NOW^XLFDT,TEMP=$$FMTE^XLFDT(TEMP,"P")
-        S TEMP=TEMP_"  Page "_PAGE
-        S TEXTLEN=$L(TEMP)
-        W ?(IOM-TEXTLEN),TEMP
-        S TEXTLEN=$L(PXRMOPT)
-        I TEXTLEN>0 D
-        .W !!
-        .W ?((IOM-TEXTLEN)/2),PXRMOPT
-        Q
-        ;
-        ;count of patients in sample
-TOTAL   N LIT
-        I PXRMTABS="Y" D  Q
-        .I PXRMREP="D" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_"APPLICABLE"_SEP_APPL Q
-        .I PXRMREP="S" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_SEP_$TR(SUB,SEP,"_") Q
-        I (PXRMRT="PXRMX")!(PXRMREP="S") W !
-        ;S LIT=" patient."
-        ;I TOTAL>1 S LIT=" patients."
-        S LIT=$S(TOTAL=0:" patients.",TOTAL=1:" patient.",1:" patients.")
-        W !,"Report run on "_TOTAL_LIT
-        I PXRMREP="D" D
-        .S LIT=$S(APPL=0:" patients.",APPL=1:" patient.",1:" patients.")
-        .W !,"Applicable to "_APPL_LIT
-        Q
-        ;
-        ;Null report prints if no patients found
-NULL    I PXRMSEL="L" D
-        .I PXRMFD="P" W !!,"No patient visits found"
-        .I PXRMFD="A" W !!,"No patient admissions found"
-        .I PXRMFD="C" W !!,"No current inpatient found"
-        .I PXRMFD="F" W !!,"No patient appointments found"
-        I PXRMSEL="P" W !!,"No patients found for provider(s) selected"
-        I "OT"[PXRMSEL W !!,"No patients found for team(s) selected"
-        Q
-        ;
-        ;Null report if no patients due/satisfied - detailed report only
-NONE    D PAGE
-        D HEAD(0)
-        W !!,"No patients with reminders "_PXRMTX
-        Q
-        ;
-SPACER(TEXT,LENGTH)     ;
-        Q
-        ;
-        ;Check for page throw
-CHECK(CNT)      ;
-        I PXRMTABS="N",$Y>(IOSL-BMARG-CNT) D PAGE
-        Q
+PXRMXGPR ; SLC/PJH - Reminder Due print calls ;01/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Called from PXRMXPR
+ ;
+ ;Print Selection criteria
+HEAD(PSTART) ;
+ I SUB="TOTAL" N NAM S NAM="TOTAL REPORT"
+ I PXRMTABS="Y" D  Q
+ .N FFAC,FNAM
+ .S FNAM=NAM
+ .I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_")
+ .I PXRMFCMB="N","LT"[PXRMSEL D  Q
+ ..S FFAC=$TR(FACPNAME,SEP,"_")
+ ..W !,"0"_SEP_FFAC_"_"_FNAM_SEP_SEP
+ .I PXRMFCMB="N","LT"'[PXRMSEL W !,"0"_SEP_FNAM_SEP_SEP Q
+ .I PXRMFCMB="Y" W !,"0"_SEP_"COMBINED_REPORT_"_FNAM_SEP_SEP Q
+ I "LT"[PXRMSEL D
+ .I PXRMFCMB="N" W !,?PSTART,"Facility: ",FACPNAME Q
+ .W !,?PSTART,"Combined Report: "
+ .N FACN,LENGTH,TEXT
+ .S FACN=0,LENGTH=17+PSTART
+ .F  S FACN=$O(PXRMFACN(FACN)) Q:'FACN  D
+ ..S TEXT=$P(PXRMFACN(FACN),U)_" ("_FACN_")"
+ ..I $O(PXRMFACN(FACN)) S TEXT=TEXT_", "
+ ..I (LENGTH+$L(TEXT))>80 S LENGTH=17+PSTART W !,?(17+PSTART)
+ ..W TEXT S LENGTH=LENGTH+$L(TEXT)
+ I "PTO"[PXRMSEL D
+ .I SUB="TOTAL" W !,?PSTART,NAM Q
+ .W !,?PSTART,"Reminders "_PXRMTX_" for ",NAM
+ I PXRMSEL="L" W !,?PSTART,"Reminders "_PXRMTX_" "_SD_" - ",NAM
+ I PXRMSEL="L" D
+ .I "PF"[PXRMFD W " for ",BD," to ",ED
+ .I PXRMFD="A" W " admissions from ",BD," to ",ED
+ .I PXRMFD="C" W " for current inpatients"
+ I PXRMSEL'="L" W " for ",SD
+ W:PXRMSEL="I" !
+ ;
+ Q
+ ;
+ ;Output the provider report criteria
+CRIT(PSTART,PLSTCRIT) ;
+ N CNT,RCCNT,RCDES,RICNT,RIDES,UNDL
+ S CNT=0
+ S UNDL=$TR($J("",79)," ","_") D LITS^PXRMXPR1
+ S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART-8)_"Report Criteria:",CNT=CNT+1
+ I PXRMTMP'="" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Report Title:",22)_$P(PXRMTMP,U,3),CNT=CNT+1
+ S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Patient Sample:",22)_PXRMFLD,CNT=CNT+1
+ I PXRMSEL'="L" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22) D DISP(.CNT,.PLSTCRIT)
+ I PXRMSEL="L" D
+ .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22)_DES,CNT=CNT+1
+ .I $E(PXRMLCSC,2)'="A" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",10) D DISP(.CNT,.PLSTCRIT)
+ I $D(PXRMRCAT) D
+ .S RCCNT=0
+ .F  S RCCNT=$O(PXRMRCAT(RCCNT)) Q:'RCCNT  D
+ ..S RCDES=$P(PXRMRCAT(RCCNT),U,2)
+ ..I RCCNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder Category:",22)_RCDES_U_6,CNT=CNT+1
+ ..I RCCNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RCDES
+ .S RICNT=0
+ .F  S RICNT=$O(PXRMREM(RICNT)) Q:'RICNT  D
+ ..S RIDES=$P(PXRMREM(RICNT),U,2)
+ ..I RICNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Individual Reminder:",22)_RIDES_U_6,CNT=CNT+1
+ ..I RICNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RIDES,CNT=CNT+1
+ S PLSTCRIT(CNT)=U_6,CNT=CNT+1
+ I PXRMREP="D" D
+ .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder:",22)_RDES,CNT=CNT+1
+ .;Display future appointments for Reminder Due report only
+ .I PXRMRT="PXRMX" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_"Appointments:" D
+ ..I PXRMFUT="Y" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"All Future Appointments",CNT=CNT+1
+ ..I PXRMFUT="N" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"Next Appointment only",CNT=CNT+1
+ I PXRMSEL="P" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("All/Primary:",22)_CDES,CNT=CNT+1
+ I PXRMSEL="L" D  S CNT=CNT+1
+ .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date Range:",22)
+ .I "PAF"[PXRMFD S PLSTCRIT(CNT)=PLSTCRIT(CNT)_BD_" to "_ED Q
+ .I PXRMFD="C" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_"not applicable" Q
+ S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Effective Due Date:",22)_SD,CNT=CNT+1
+ S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date run:",22)_RD,CNT=CNT+1
+ I PXRMTMP'="" D 
+ .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Template Name:",22)_$P(PXRMTMP,U,2),CNT=CNT+1
+ .I PXRMUSER S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Requested by:",22)_$$GET1^DIQ(200,DUZ,.01)_U_3,CNT=CNT+1
+ I (PXRMFCMB="Y")!(PXRMLCMB="Y")!(PXRMTCMB="Y") D
+ .N LIT,TEXT
+ .S LIT=$S(PXRMSEL="P":"Providers","OT"[PXRMSEL:"Teams",1:"Locations")
+ .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Combined report:",22)
+ .I PXRMFCMB="Y",PXRMLCMB="Y" S TEXT="Combined Facility and Combined "_LIT
+ .I PXRMFCMB="Y",PXRMLCMB="N" S TEXT="Combined Facility by Individual "_LIT
+ .I PXRMLCMB="Y",PXRMFCMB="N" S TEXT="Combined "_LIT
+ .I PXRMTCMB="Y" S TEXT="Combined "_LIT
+ .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ I PXRMREP="S","IRT"[PXRMTOT,"IR"'[PXRMSEL D
+ .N LIT1,LIT2,LIT3,TEXT
+ .D LIT^PXRMXD
+ .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Summary report:",22)
+ .I PXRMTOT="I" S TEXT=LIT1
+ .I PXRMTOT="R" S TEXT=LIT2
+ .I PXRMTOT="T" S TEXT=LIT3
+ .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART,.CNT,.PLSTCRIT)
+ N CHECK,CNT,NODE,STR
+ S CNT=0 F  S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0  D
+ .S NODE=$G(PLSTCRIT(CNT)),CHECK=$P(NODE,U,2),STR=$P(NODE,U)
+ .I CHECK>0 D CHECK(CHECK) I STR="" Q
+ .W !,STR
+ W !,UNDL,!
+ Q
+ ;
+ ;Display selected teams/providers
+DISP(CNT,PLSTCRIT) ;
+ N IC
+ S IC=""
+ I PXRMSEL="P" F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D
+ .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPRV(IC),U,2),CNT=CNT+1
+ .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPRV(IC),U,2),CNT=CNT+1
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ I PXRMSEL="T" F  S IC=$O(PXRMPCM(IC)) Q:IC=""  D
+ .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPCM(IC),U,2),CNT=CNT+1
+ .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPCM(IC),U,2),CNT=CNT+1
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ I PXRMSEL="O" F  S IC=$O(PXRMOTM(IC)) Q:IC=""  D
+ .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMOTM(IC),U,3),CNT=CNT+1
+ .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMOTM(IC),U,2),CNT=CNT+1
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ I PXRMSEL="I" F  S IC=$O(PXRMPAT(IC)) Q:IC=""  D
+ .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPAT(IC),U,2),CNT=CNT+1
+ .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPAT(IC),U,2),CNT=CNT+1
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ I PXRMSEL="R" F  S IC=$O(PXRMLIST(IC)) Q:IC=""  D
+ .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMLIST(IC),U,2),CNT=CNT+1
+ .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMLIST(IC),U,2),CNT=CNT+1
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ I PXRMSEL="L" D
+ .I $E(PXRMLCSC)="H" F  S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC=""  D
+ ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(^XTMP(PXRMXTMP,"HLOC",IC),U,2),CNT=CNT+1
+ ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ .I $E(PXRMLCSC)="C" F  S IC=$O(PXRMCS(IC)) Q:IC=""  D
+ ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCS(IC),U,1)_" "_$P(PXRMCS(IC),U,3),CNT=CNT+1
+ ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ .I $E(PXRMLCSC)="G" F  S IC=$O(PXRMCGRP(IC)) Q:IC=""  D
+ ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCGRP(IC),U,2),CNT=CNT+1
+ ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ Q
+ ;
+ ;Output the service categories
+OSCAT(SCL,PSTART,CNT,PLSTCRIT) ;
+ N IC,CSTART,EM,SC,SCTEXT
+ S CSTART=PSTART+3
+ S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Service categories:",22)_SCL,CNT=CNT+1
+ F IC=1:1:$L(SCL,",") D
+ .S SC=$P(SCL,",",IC)
+ .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
+ .S PLSTCRIT(CNT)=U_3,CNT=CNT+1
+ .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",CSTART)_SC_" - "_SCTEXT,CNT=CNT+1
+ Q
+ ;
+ ;If necessary, write the header
+COL(NEWPAGE) ;
+ I NEWPAGE D  Q:DONE
+ .I PXRMTABS="N" D PAGE
+ .I PXRMTABS="Y" W !!
+ D CHECK(0) Q:DONE
+ D HEAD(0)
+ S HEAD=0
+ I PXRMTABS="Y" Q
+ I PXRMREP="D" D
+ .N PNAM
+ .S PNAM=$P(PXRMREM(1),U,4) I PNAM="" S PNAM=$P(PXRMREM(1),U,2)
+ .W !!,PNAM,":  ",COUNT
+ .W:COUNT>1 " patients have the reminder "_PXRMTX
+ .W:COUNT=1 " patient has the reminder "_PXRMTX
+ N IC F IC=0:1:2 W !,?PXRMT(IC),PXRMH(IC)
+ Q
+ ;
+ ;form feed to new page
+PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
+ .S DIR(0)="E"
+ .W !
+ .D ^DIR K DIR
+ I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
+ W:$D(IOF)&(PAGE>0) @IOF
+ S PAGE=PAGE+1,FIRST=0
+ I $E(IOST)="C",IO=IO(0) W @IOF
+ E  W !
+ N TEMP,TEXTLEN
+ S TEMP=$$NOW^XLFDT,TEMP=$$FMTE^XLFDT(TEMP,"P")
+ S TEMP=TEMP_"  Page "_PAGE
+ S TEXTLEN=$L(TEMP)
+ W ?(IOM-TEXTLEN),TEMP
+ S TEXTLEN=$L(PXRMOPT)
+ I TEXTLEN>0 D
+ .W !!
+ .W ?((IOM-TEXTLEN)/2),PXRMOPT
+ Q
+ ;
+ ;count of patients in sample
+TOTAL N LIT
+ I PXRMTABS="Y" D  Q
+ .I PXRMREP="D" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_"APPLICABLE"_SEP_APPL Q
+ .I PXRMREP="S" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_SEP_$TR(SUB,SEP,"_") Q
+ I (PXRMRT="PXRMX")!(PXRMREP="S") W !
+ ;S LIT=" patient."
+ ;I TOTAL>1 S LIT=" patients."
+ S LIT=$S(TOTAL=0:" patients.",TOTAL=1:" patient.",1:" patients.")
+ W !,"Report run on "_TOTAL_LIT
+ I PXRMREP="D" D
+ .S LIT=$S(APPL=0:" patients.",APPL=1:" patient.",1:" patients.")
+ .W !,"Applicable to "_APPL_LIT
+ Q
+ ;
+ ;Null report prints if no patients found
+NULL I PXRMSEL="L" D
+ .I PXRMFD="P" W !!,"No patient visits found"
+ .I PXRMFD="A" W !!,"No patient admissions found"
+ .I PXRMFD="C" W !!,"No current inpatient found"
+ .I PXRMFD="F" W !!,"No patient appointments found"
+ I PXRMSEL="P" W !!,"No patients found for provider(s) selected"
+ I "OT"[PXRMSEL W !!,"No patients found for team(s) selected"
+ Q
+ ;
+ ;Null report if no patients due/satisfied - detailed report only
+NONE D PAGE
+ D HEAD(0)
+ W !!,"No patients with reminders "_PXRMTX
+ Q
+ ;
+SPACER(TEXT,LENGTH) ;
+ Q
+ ;
+ ;Check for page throw
+CHECK(CNT) ;
+ I PXRMTABS="N",$Y>(IOSL-BMARG-CNT) D PAGE
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m

@@ -1 @@
-PXRMXGUT        ; SLC/PJH - General utilities for reminder reports; 11/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;=======================================
-EOR     ;End of report display.
-        I $E(IOST,1,2)="C-",IO=IO(0) D
-        . S DIR(0)="EA"
-        . S DIR("A")="End of the report. Press ENTER/RETURN to continue..."
-        . W !
-        . D ^DIR K DIR
-        Q
-        ;
-        ;=======================================
-EXIT    ;Clean things up.
-        D ^%ZISC
-        D HOME^%ZIS
-        K IO("Q")
-        K DIRUT,DTOUT,DUOUT,POP
-        K ^TMP(PXRMXTMP)
-        K ^XTMP(PXRMXTMP)
-        K ^TMP("PXRMX",$J)
-        K ^TMP($J,"PXRM PATIENT LIST")
-        K ^TMP($J,"PXRM PATIENT EVAL")
-        K ^TMP($J,"PXRM FUTURE APPT")
-        K ^TMP($J,"PXRM FACILITY FUTURE APPT")
-        K ^TMP($J,"SDAMA301")
-        K ^TMP($J,"SORT")
-        Q
-        ;
-        ;=======================================
-TIMING  ;Print report timing data.
-        N IND
-        W !!,"Report timing data:"
-        S IND=""
-        F  S IND=$O(^XTMP(PXRMXTMP,"TIMING",IND)) Q:IND=""  W !," ",^XTMP(PXRMXTMP,"TIMING",IND)
-        Q
-        ;
-        ;=======================================
-USTRINS(STRING,CHAR)    ;Given a string, which is assumed to be in alphabetical
-        ;order and a character which is not already in the string insert the
-        ;character into the string in alphabetical order. For example:
-        ;STRING CHAR RETURNS
-        ;CEQ     A    ACEQ
-        ;CEQ     E    CEQ
-        ;CEQ     F    CEFQ
-        ;CEQ     T    CEQT
-        ;
-        N CH1,CH2,DONE,IC,LEN,STR
-        S LEN=$L(STRING)
-        ;Special case of empty STRING.
-        I LEN=0 Q CHAR
-        ;
-        S DONE=0
-        S STR=""
-        S CH1=$E(STRING,1,1)
-        I (CH1]CHAR) S STR=STR_CHAR_CH1,DONE=1
-        E  S STR=STR_CH1
-        I CH1=CHAR S DONE=1
-        ;
-        ;Special case of STRING of length 1.
-        I (LEN=1)&('DONE) S STR=STR_CHAR,DONE=1
-        ;
-        F IC=2:1:LEN D
-        . S CH2=$E(STRING,IC,IC)
-        . I DONE S STR=STR_CH2
-        . E  D
-        .. I (CHAR]CH1)&(CH2]CHAR) S STR=STR_CHAR_CH2,DONE=1
-        .. E  S STR=STR_CH2
-        .. I CH2=CHAR S DONE=1
-        .. S CH1=CH2
-        ;
-        ;If we made it all the way through the loop and we are still not
-        ;done then append CHAR.
-        I ('DONE) S STR=STR_CHAR
-        Q STR
-        ;
-        ;=======================================
-VLIST(SLIST,LIST,MESSAGE)       ;Make sure all the elements of LIST are in
-        ;SLIST.  If they are, then LIST is valid.  The elements of LIST can be
-        ;separated by commas and spaces.
-        N IC,LE,LEN,VALID
-        S LIST=$TR(LIST,",","")
-        S LIST=$TR(LIST," ","")
-        ;Make the test case insensitive.
-        S SLIST=$$UP^XLFSTR(SLIST)
-        S LIST=$$UP^XLFSTR(LIST)
-        S VALID=1
-        S LEN=$L(LIST)
-        I LEN=0 D
-        . W !,"The list is empty!"
-        . S VALID=0
-        F IC=1:1:LEN D
-        . S LE=$E(LIST,IC,IC)
-        . I SLIST'[LE D
-        .. W !,LE,MESSAGE
-        .. S VALID=0
-        Q VALID
-        ;
+PXRMXGUT ; SLC/PJH - General utilities for reminder reports; 05/31/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=======================================
+EOR ;End of report display.
+ I $E(IOST)="C",IO=IO(0) D
+ . S DIR(0)="EA"
+ . S DIR("A")="End of the report. Press ENTER/RETURN to continue..."
+ . W !
+ . D ^DIR K DIR
+ Q
+ ;
+ ;=======================================
+EXIT ;Clean things up.
+ D ^%ZISC
+ D HOME^%ZIS
+ K IO("Q")
+ K DIRUT,DTOUT,DUOUT,POP
+ K ^TMP(PXRMXTMP)
+ K ^XTMP(PXRMXTMP)
+ K ^TMP("PXRMX",$J)
+ K ^TMP($J,"PXRM PATIENT LIST")
+ K ^TMP($J,"PXRM PATIENT EVAL")
+ K ^TMP($J,"PXRM FUTURE APPT")
+ K ^TMP($J,"PXRM FACILITY FUTURE APPT")
+ K ^TMP($J,"SDAMA301")
+ K ^TMP($J,"SORT")
+ Q
+ ;
+ ;=======================================
+VLIST(SLIST,LIST,MESSAGE) ;Make sure all the elements of LIST are in
+ ;SLIST.  If they are, then LIST is valid.  The elements of LIST can be
+ ;separated by commas and spaces.
+ N IC,LE,LEN,VALID
+ S LIST=$TR(LIST,",","")
+ S LIST=$TR(LIST," ","")
+ ;Make the test case insensitive.
+ S SLIST=$$UP^XLFSTR(SLIST)
+ S LIST=$$UP^XLFSTR(LIST)
+ S VALID=1
+ S LEN=$L(LIST)
+ I LEN=0 D
+ . W !,"The list is empty!"
+ . S VALID=0
+ F IC=1:1:LEN D
+ . S LE=$E(LIST,IC,IC)
+ . I SLIST'[LE D
+ .. W !,LE,MESSAGE
+ .. S VALID=0
+ Q VALID
+ ;
+ ;=======================================
+USTRINS(STRING,CHAR) ;Given a string, which is assumed to be in alphabetical
+ ;order and a character which is not already in the string insert the
+ ;character into the string in alphabetical order. For example:
+ ;STRING CHAR RETURNS
+ ;CEQ     A    ACEQ
+ ;CEQ     E    CEQ
+ ;CEQ     F    CEFQ
+ ;CEQ     T    CEQT
+ ;
+ N CH1,CH2,DONE,IC,LEN,STR
+ S LEN=$L(STRING)
+ ;Special case of empty STRING.
+ I LEN=0 Q CHAR
+ ;
+ S DONE=0
+ S STR=""
+ S CH1=$E(STRING,1,1)
+ I (CH1]CHAR) S STR=STR_CHAR_CH1,DONE=1
+ E  S STR=STR_CH1
+ I CH1=CHAR S DONE=1
+ ;
+ ;Special case of STRING of length 1.
+ I (LEN=1)&('DONE) S STR=STR_CHAR,DONE=1
+ ;
+ F IC=2:1:LEN D
+ . S CH2=$E(STRING,IC,IC)
+ . I DONE S STR=STR_CH2
+ . E  D
+ .. I (CHAR]CH1)&(CH2]CHAR) S STR=STR_CHAR_CH2,DONE=1
+ .. E  S STR=STR_CH2
+ .. I CH2=CHAR S DONE=1
+ .. S CH1=CH2
+ ;
+ ;If we made it all the way through the loop and we are still not
+ ;done then append CHAR.
+ I ('DONE) S STR=STR_CHAR
+ Q STR
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m

@@ -1 @@
-PXRMXPR ; SLC/PJH - Print Reminder Due report. ;11/27/2006
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ; Called/Jobbed after PXRMXSE1
-        ;
-START   N BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD
-        N INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP
-        N PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH
-        N BD,ED,EMPCHK,SD,RD
-        N PXRMTX
-        S PXRMTX="due"
-        ;
-        I PXRMREP="D" D
-        .S EMPCHK=$P($G(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U)
-        .I EMPCHK="" S EMPCHK="Y"
-        ;
-        ; Format Date Range
-        I PXRMSEL="L" D
-        .S BD=$$FMTE^XLFDT(PXRMBDT,"5D")
-        .S ED=$$FMTE^XLFDT(PXRMEDT,"5D")
-        ; Format due effective date
-        S SD=$$FMTE^XLFDT(PXRMSDT,"5P")
-        ; Format run date
-        S RD=$$FMTE^XLFDT(PXRMXST,"5P")
-        ;
-        U IO
-        S DONE=0
-        ;
-        ;Delimited report.
-        S SEP=$S(PXRMTABS="Y":PXRMTABC,1:"")
-        ;
-        ;Setup initial formatting parameters.
-        S INDENT=3
-        S BMARG=2,PAGE=0,HEAD=1
-        ;
-        I +$G(XQY)>0 N XQOPT D OP^XQCHK
-        S PXRMOPT=$P($G(XQOPT),U,2)
-        I ($L(PXRMOPT)>0)&(PXRMOPT'["Clinical") S PXRMOPT="Clinical "_PXRMOPT
-        I PXRMREP="D" D
-        .S RDES=$P(REMINDER(1),U,2)
-        .S PXRMOPT=PXRMOPT_" - Detailed Report"
-        .N IC F IC=0,3,4 S PXRMH(IC)="",PXRMT(IC)=0
-        .S PXRMH(1)="Date Due    Last Done   Next Appt"
-        .S PXRMH(2)="--------    ---------   ---------"
-        .I $G(PXRMINP) D
-        ..S PXRMH(1)="Date Due    Last Done   Ward/Bed"
-        ..S PXRMH(2)="--------    ---------   --------"
-        .F IC=1,2 S PXRMT(IC)=40
-        .S ADES="Next Appointment only"
-        .I PXRMFUT="Y" S ADES="All Future Appointments"
-        .S SDES="Sorted by Patient Name"
-        .I PXRMSRT="Y" S SDES="Sorted by Appointment Date"
-        I PXRMREP="S" D
-        .S PXRMOPT=PXRMOPT_" - Summary Report"
-        .S PXRMH(0)="# Patients with Reminders",PXRMT(0)=50
-        .S PXRMH(1)="Applicable           Due"
-        .S PXRMH(2)="----------           ---"
-        .N IC F IC=1,2 S PXRMT(IC)=50
-        .S PXRMH(3)="Denominator"
-        .S PXRMH(4)="-----------"
-        .F IC=3,4 S PXRMT(IC)=0
-        ;
-        ;Print Criteria Page if normal report
-        S CRITERIA=0 I PXRMTABS="N" S CRITERIA=1
-        ;or delimited report with notemplate
-        I PXRMTABS="Y",PXRMTMP="" S CRITERIA=1
-        ;
-        ;Build array of locations/providers with no patients selected in
-        ;MISSED.
-        D NOPATS^PXRMXPR1(.MISSED)
-        ;
-        ;Print either criteria page or summary header
-        I CRITERIA D  G:DONE EXIT
-        .D PAGE^PXRMXGPR Q:DONE
-        .D CRIT^PXRMXGPR(10,.PLSTCRIT) Q:DONE
-        ;Header if delimited output from a template
-        I 'CRITERIA D
-        .N HDR1,HDR2,HDR3
-        .S HDR1="",HDR2="",HDR3=""
-        .I PXRMTMP]"" S HDR1="TITLE:"_$P(PXRMTMP,U,2)_U_"TEMPLATE:"_$P(PXRMTMP,U,3)
-        .I PXRMTMP="" D
-        ..N PXRMFLD,DES,CDES D LITS^PXRMXPR1 S HDR1=PXRMFLD_U_$G(DES)_U_$G(CDES)
-        .I PXRMSEL="L" S HDR2="START:"_BD_U_"END:"_ED
-        .S HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD
-        .I PXRMFCMB="Y" S HDR3="COMBINED FACILITY"
-        .I PXRMLCMB="Y" S $P(HDR3,SEP,2)="COMBINED LOCATION"
-        .I PXRMTCMB="Y" S $P(HDR3,SEP,2)="COMBINED OE/RR TEAMS"
-        .I PXRMREP="S" D
-        ..N LIT1,LIT2,LIT3
-        ..D LIT^PXRMXD
-        ..I PXRMTOT="I" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT1)
-        ..I PXRMTOT="R" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT2)
-        ..I PXRMTOT="T" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT3)
-        .S PLSTCRIT(1)=HDR1,PLSTCRIT(2)=HDR2,PLSTCRIT(3)=HDR3
-        .W !,HDR1,!,HDR2,!,HDR3,!
-        ;
-        ;Kill items marked as found
-        K ^XTMP(PXRMXTMP,"MARKED AS FOUND")
-        ;
-        ;Setup the final formatting parameters.
-        S C1HS=INDENT+3
-        S C1S=0
-        S C2HS=C1S+2
-        S C2S=C2HS
-        S C3HS=C2HS+5
-        S C3S=C3HS
-        S HEAD=1
-        S INDENT=10
-        ;
-        ; Update last run date 
-        I $G(PXRMTMP)'="" D UPD^PXRMXTU
-        ;
-        ; Get report detail from ^XTMP
-        N PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL
-        S TTOTAL=0
-        ; Set subroutine label from report format
-        S MOD="SUMARY" I PXRMREP="D" S MOD="DETAIL"
-        ;
-        S FAC=0,PX="PXRM"
-        F  S FAC=$O(^XTMP(PXRMXTMP,PX,FAC)) Q:FAC=""  Q:DONE  D
-        .;Get facility name for Location and PCMM team report
-        .I "TL"[PXRMSEL,PXRMFCMB="N" D
-        ..S FACPNAME=$P(PXRMFACN(FAC),U,1)_"  "_$P(PXRMFACN(FAC),U,2)
-        .;Report from ^XTMP - label MOD is DETAIL/SUMARY
-        .S (PNAM,SUB,NAM,SRT)=""
-        .I PXRMSEL="I" S SUB="INDIVIDUAL PATIENTS" D @MOD Q:DONE
-        .I PXRMSEL'="I" D
-        ..;Sort internal IENs into alpha order
-        ..D XSORT
-        ..F  S SRT=$O(^TMP($J,"SORT",SRT)) Q:SRT=""  Q:DONE  D
-        ...S SUB=$G(^TMP($J,"SORT",SRT)) D @MOD
-        ..I MOD="SUMARY","RT"[PXRMTOT S SUB="TOTAL" D @MOD
-        ;
-        ; Null report if no patients selected
-        I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT
-        ; Report selected patient sample with no patients
-        I $D(MISSED),PXRMPML=1 D MISSED^PXRMXPR1(0,.MISSED)
-        ;
-        ;Print Patient List
-        I $G(PATLST)="Y" D FOOTER^PXRMXPR1(.PLSTCRIT)
-        ;
-        ;Print Error message
-        I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY
-EXIT    ;
-        D TIMING^PXRMXGUT
-        D EXIT^PXRMXGUT
-        ;
-        ;Allow the task to be cleaned up upon successful completion.
-        I $D(ZTQUEUED) S ZTREQ="@"
-        ;
-        D EOR^PXRMXGUT
-        Q
-        ;
-        ;Report by Patient
-DETAIL  N JJ,VA,DATE,COUNT,DDAT,EMP
-        N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT
-        S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
-        S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1)
-        S DDAT="",JJ=0
-        ; Get list of patients for each appointment date
-        F  S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT=""  Q:DONE  D PAT
-        ; No patients due
-        I JJ=0 D:'DONE NONE^PXRMXGPR
-        ; Total patients
-        D:'DONE TOTAL^PXRMXGPR
-        S TTOTAL=TTOTAL+TOTAL
-        Q
-        ;
-PAT     ;Extract and print patient detail
-        N DNEXT1,NODE,PNUM
-        F  S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM=""  Q:DONE  D
-        .S JJ=JJ+1
-        .;Format print line
-        .S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D 
-        ..S FDAT2="N/A",FDAT3="None"
-        ..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
-        ..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4)
-        ..S BED=$P(NODE,U,5)
-        ..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2)
-        ..I PXRMSSN="N" S BID=$E(BID,6,9)
-        ..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9)
-        ..S BID="("_BID_")"
-        ..S FDAT1=$$FMTE^XLFDT(DDUE,"5D")
-        ..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D")
-        ..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D")
-        ..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D")
-        .;Print
-        .D CHECK Q:DONE
-        .;Normal output
-        .I PXRMTABS="N" D
-        ..S PNUM=JJ#10000
-        ..S PNUM=$$RJ^XLFSTR(PNUM,4)
-        ..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2
-        ..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3)
-        ..I $G(PXRMINP) W ?64,BED
-        ..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1
-        .;Delimited report
-        .I PXRMTABS="Y" D
-        ..N FNAM
-        ..S FNAM=$P($G(PNAM),U)
-        ..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID
-        ..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_")
-        ..I BED="NONE" S BED=" "
-        ..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED
-        ..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED
-        .;---
-        .; Future Appointments
-        .I PXRMFUT="Y" D
-        ..N CNT,ADAT,ALOC,ATYP,FIRST,NONE
-        ..S CNT=0,NONE=1,FIRST=1
-        ..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q
-        ..F  S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0  D
-        ...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U)
-        ...I PXRMDLOC="Y" D
-        ....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2)
-        ....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3)
-        ...S ADAT=$$FMTE^XLFDT(ADAT,"2P")
-        ...I FIRST D  S FIRST=0,NONE=0
-        ....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"")
-        ...D CHECK
-        ...I PXRMDLOC="Y" D
-        ....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20)
-        ....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20)
-        ...I PXRMDLOC="N" D
-        ....I PXRMTABS="N" W !,?10,ADAT
-        ....I PXRMTABS="Y" W SEP_ADAT
-        ..I NONE,PXRMTABS="N" W ?64,FDAT3
-        ..I NONE,PXRMTABS="Y" W SEP_FDAT3
-        ..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"")
-        ..K ^UTILITY("VASD",$J)
-        Q
-        ;
-        ;Summary by Reminder
-SUMARY  N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT
-        S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
-        S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
-        S RNUM=$O(REMINDER(""),-1)
-        ;Get reminders in alpha order
-        F JJ=1:1:RNUM D  Q:DONE
-        .S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
-        .S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
-        .; zero lines will be printed 
-        .S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM))
-        .S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
-        .;Print
-        .D CHECK Q:DONE
-        .;Normal Report
-        .I PXRMTABS="N" W !,JJ,?5,RNAM,?48,$J(EVAL,10),?63,$J(DUE,10)
-        .;Condensed Report
-        .I PXRMTABS="Y" D
-        ..I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_")
-        ..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")
-        D:'DONE TOTAL^PXRMXGPR
-        I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL
-        I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL
-        Q
-        ;
-        ;Check line count before writing line
-CHECK   I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1)
-        Q
-        ;
-        ;Check if employee
-EMP     N VAEL
-        D ELIG^VADPT
-        ;Check TYPE (#391) field
-        I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q
-        ;Check PATIENT ELIGABILITY (#361) field
-        N ELIG
-        S ELIG=0,EMP=0
-        F  S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG  D  Q:EMP
-        .I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1
-        Q
-        ;
-        ;Sort internal numbers into Alpha order
-XSORT   N SUB,NAM
-        K ^TMP($J,"SORT")
-        S SUB=""
-        F  S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB=""  D
-        .Q:SUB="TOTAL"
-        .S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U)
-        .I NAM="" S NAM=SUB
-        .S ^TMP($J,"SORT",NAM)=SUB
-        Q
-        ;
+PXRMXPR ; SLC/PJH - Print Reminder Due report. ;01/14/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ; Called/Jobbed after PXRMXSE1
+ ;
+START N BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD
+ N INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP
+ N PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH
+ N BD,ED,EMPCHK,SD,RD
+ N PXRMTX
+ S PXRMTX="due"
+ ;
+ I PXRMREP="D" D
+ .S EMPCHK=$P($G(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U)
+ .I EMPCHK="" S EMPCHK="Y"
+ ;
+ ; Format Date Range
+ I PXRMSEL="L" D
+ .S BD=$$FMTE^XLFDT(PXRMBDT,"5D")
+ .S ED=$$FMTE^XLFDT(PXRMEDT,"5D")
+ ; Format due effective date
+ S SD=$$FMTE^XLFDT(PXRMSDT,"5P")
+ ; Format run date
+ S RD=$$FMTE^XLFDT(PXRMXST,"5P")
+ ;
+ U IO
+ S DONE=0
+ ;
+ ;Delimited report.
+ S SEP=$S(PXRMTABS="Y":PXRMTABC,1:"")
+ ;
+ ;Setup initial formatting parameters.
+ S INDENT=3
+ S BMARG=2,PAGE=0,HEAD=1
+ ;
+ I +$G(XQY)>0 N XQOPT D OP^XQCHK
+ S PXRMOPT=$P($G(XQOPT),U,2)
+ I ($L(PXRMOPT)>0)&(PXRMOPT'["Clinical") S PXRMOPT="Clinical "_PXRMOPT
+ I PXRMREP="D" D
+ .S RDES=$P(REMINDER(1),U,2)
+ .S PXRMOPT=PXRMOPT_" - Detailed Report"
+ .N IC F IC=0,3,4 S PXRMH(IC)="",PXRMT(IC)=0
+ .S PXRMH(1)="Date Due    Last Done   Next Appt"
+ .S PXRMH(2)="--------    ---------   ---------"
+ .I $G(PXRMINP) D
+ ..S PXRMH(1)="Date Due    Last Done   Ward/Bed"
+ ..S PXRMH(2)="--------    ---------   --------"
+ .F IC=1,2 S PXRMT(IC)=40
+ .S ADES="Next Appointment only"
+ .I PXRMFUT="Y" S ADES="All Future Appointments"
+ .S SDES="Sorted by Patient Name"
+ .I PXRMSRT="Y" S SDES="Sorted by Appointment Date"
+ I PXRMREP="S" D
+ .S PXRMOPT=PXRMOPT_" - Summary Report"
+ .S PXRMH(0)="# Patients with Reminders",PXRMT(0)=50
+ .S PXRMH(1)="Applicable           Due"
+ .S PXRMH(2)="----------           ---"
+ .N IC F IC=1,2 S PXRMT(IC)=50
+ .S PXRMH(3)="Denominator"
+ .S PXRMH(4)="-----------"
+ .F IC=3,4 S PXRMT(IC)=0
+ ;
+ ;Print Criteria Page if normal report
+ S CRITERIA=0 I PXRMTABS="N" S CRITERIA=1
+ ;or delimited report with notemplate
+ I PXRMTABS="Y",PXRMTMP="" S CRITERIA=1
+ ;
+ ;Build array of locations/providers with no patients selected in
+ ;MISSED.
+ D NOPATS^PXRMXPR1(.MISSED)
+ ;
+ ;Print either criteria page or summary header
+ I CRITERIA D  G:DONE EXIT
+ .D PAGE^PXRMXGPR Q:DONE
+ .D CRIT^PXRMXGPR(10,.PLSTCRIT) Q:DONE
+ ;Header if delimited output from a template
+ I 'CRITERIA D
+ .N HDR1,HDR2,HDR3
+ .S HDR1="",HDR2="",HDR3=""
+ .I PXRMTMP]"" S HDR1="TITLE:"_$P(PXRMTMP,U,2)_U_"TEMPLATE:"_$P(PXRMTMP,U,3)
+ .I PXRMTMP="" D
+ ..N PXRMFLD,DES,CDES D LITS^PXRMXPR1 S HDR1=PXRMFLD_U_$G(DES)_U_$G(CDES)
+ .I PXRMSEL="L" S HDR2="START:"_BD_U_"END:"_ED
+ .S HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD
+ .I PXRMFCMB="Y" S HDR3="COMBINED FACILITY"
+ .I PXRMLCMB="Y" S $P(HDR3,SEP,2)="COMBINED LOCATION"
+ .I PXRMTCMB="Y" S $P(HDR3,SEP,2)="COMBINED OE/RR TEAMS"
+ .I PXRMREP="S" D
+ ..N LIT1,LIT2,LIT3
+ ..D LIT^PXRMXD
+ ..I PXRMTOT="I" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT1)
+ ..I PXRMTOT="R" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT2)
+ ..I PXRMTOT="T" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT3)
+ .S PLSTCRIT(1)=HDR1,PLSTCRIT(2)=HDR2,PLSTCRIT(3)=HDR3
+ .W !,HDR1,!,HDR2,!,HDR3,!
+ ;
+ ;Kill items marked as found
+ K ^XTMP(PXRMXTMP,"MARKED AS FOUND")
+ ;
+ ;Setup the final formatting parameters.
+ S C1HS=INDENT+3
+ S C1S=0
+ S C2HS=C1S+2
+ S C2S=C2HS
+ S C3HS=C2HS+5
+ S C3S=C3HS
+ S HEAD=1
+ S INDENT=10
+ ;
+ ; Update last run date 
+ I $G(PXRMTMP)'="" D UPD^PXRMXTU
+ ;
+ ; Get report detail from ^XTMP
+ N PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL
+ S TTOTAL=0
+ ; Set subroutine label from report format
+ S MOD="SUMARY" I PXRMREP="D" S MOD="DETAIL"
+ ;
+ S FAC=0,PX="PXRM"
+ F  S FAC=$O(^XTMP(PXRMXTMP,PX,FAC)) Q:FAC=""  Q:DONE  D
+ .;Get facility name for Location and PCMM team report
+ .I "TL"[PXRMSEL,PXRMFCMB="N" D
+ ..S FACPNAME=$P(PXRMFACN(FAC),U,1)_"  "_$P(PXRMFACN(FAC),U,2)
+ .;Report from ^XTMP - label MOD is DETAIL/SUMARY
+ .S (PNAM,SUB,NAM,SRT)=""
+ .I PXRMSEL="I" S SUB="INDIVIDUAL PATIENTS" D @MOD Q:DONE
+ .I PXRMSEL'="I" D
+ ..;Sort internal IENs into alpha order
+ ..D XSORT
+ ..F  S SRT=$O(^TMP($J,"SORT",SRT)) Q:SRT=""  Q:DONE  D
+ ...S SUB=$G(^TMP($J,"SORT",SRT)) D @MOD
+ ..I MOD="SUMARY","RT"[PXRMTOT S SUB="TOTAL" D @MOD
+ ;
+ ; Null report if no patients selected
+ I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT
+ ; Report selected patient sample with no patients
+ I $D(MISSED) D MISSED^PXRMXPR1(0,.MISSED)
+ ;
+ ;Print Patient List
+ I $G(PATLST)="Y" D FOOTER^PXRMXPR1(.PLSTCRIT)
+ ;
+ ;Print Error message
+ I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY
+EXIT ;
+ D EXIT^PXRMXGUT
+ ;
+ ;Allow the task to be cleaned up upon successful completion.
+ I $D(ZTQUEUED) S ZTREQ="@"
+ ;
+ D EOR^PXRMXGUT
+ Q
+ ;
+ ;Report by Patient
+DETAIL N JJ,VA,DATE,COUNT,DDAT,EMP
+ N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT
+ S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
+ S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1)
+ S DDAT="",JJ=0
+ ; Get list of patients for each appointment date
+ F  S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT=""  Q:DONE  D PAT
+ ; No patients due
+ I JJ=0 D:'DONE NONE^PXRMXGPR
+ ; Total patients
+ D:'DONE TOTAL^PXRMXGPR
+ S TTOTAL=TTOTAL+TOTAL
+ Q
+ ;
+PAT ;Extract and print patient detail
+ N DNEXT1,NODE,PNUM
+ F  S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM=""  Q:DONE  D
+ .S JJ=JJ+1
+ .;Format print line
+ .S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D 
+ ..S FDAT2="N/A",FDAT3="None"
+ ..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM))
+ ..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4)
+ ..S BED=$P(NODE,U,5)
+ ..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2)
+ ..I PXRMSSN="N" S BID=$E(BID,6,9)
+ ..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9)
+ ..S BID="("_BID_")"
+ ..S FDAT1=$$FMTE^XLFDT(DDUE,"5D")
+ ..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D")
+ ..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D")
+ ..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D")
+ .;Print
+ .D CHECK Q:DONE
+ .;Normal output
+ .I PXRMTABS="N" D
+ ..S PNUM=JJ#10000
+ ..S PNUM=$$RJ^XLFSTR(PNUM,4)
+ ..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2
+ ..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3)
+ ..I $G(PXRMINP) W ?64,BED
+ ..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1
+ .;Delimited report
+ .I PXRMTABS="Y" D
+ ..N FNAM
+ ..S FNAM=$P($G(PNAM),U)
+ ..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID
+ ..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_")
+ ..I BED="NONE" S BED=" "
+ ..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED
+ ..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED
+ .;---
+ .; Future Appointments
+ .I PXRMFUT="Y" D
+ ..N CNT,ADAT,ALOC,ATYP,FIRST,NONE
+ ..S CNT=0,NONE=1,FIRST=1
+ ..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q
+ ..F  S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0  D
+ ...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U)
+ ...I PXRMDLOC="Y" D
+ ....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2)
+ ....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3)
+ ...S ADAT=$$FMTE^XLFDT(ADAT,"2P")
+ ...I FIRST D  S FIRST=0,NONE=0
+ ....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"")
+ ...D CHECK
+ ...I PXRMDLOC="Y" D
+ ....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20)
+ ....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20)
+ ...I PXRMDLOC="N" D
+ ....I PXRMTABS="N" W !,?10,ADAT
+ ....I PXRMTABS="Y" W SEP_ADAT
+ ..I NONE,PXRMTABS="N" W ?64,FDAT3
+ ..I NONE,PXRMTABS="Y" W SEP_FDAT3
+ ..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"")
+ ..K ^UTILITY("VASD",$J)
+ Q
+ ;
+ ;Summary by Reminder
+SUMARY N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT
+ S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1
+ S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1)
+ S RNUM=$O(REMINDER(""),-1)
+ ;Get reminders in alpha order
+ F JJ=1:1:RNUM D  Q:DONE
+ .S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4)
+ .S:RNAM="" RNAM=$P(REMINDER(JJ),U,2)
+ .; zero lines will be printed 
+ .S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM))
+ .S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2)
+ .;Print
+ .D CHECK Q:DONE
+ .;Normal Report
+ .I PXRMTABS="N" W !,JJ,?5,RNAM,?48,$J(EVAL,10),?63,$J(DUE,10)
+ .;Condensed Report
+ .I PXRMTABS="Y" D
+ ..I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_")
+ ..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_")
+ D:'DONE TOTAL^PXRMXGPR
+ I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL
+ I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL
+ Q
+ ;
+ ;Check line count before writing line
+CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1)
+ Q
+ ;
+ ;Check if employee
+EMP N VAEL
+ D ELIG^VADPT
+ ;Check TYPE (#391) field
+ I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q
+ ;Check PATIENT ELIGABILITY (#361) field
+ N ELIG
+ S ELIG=0,EMP=0
+ F  S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG  D  Q:EMP
+ .I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1
+ Q
+ ;
+ ;Sort internal numbers into Alpha order
+XSORT N SUB,NAM
+ K ^TMP($J,"SORT")
+ S SUB=""
+ F  S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB=""  D
+ .Q:SUB="TOTAL"
+ .S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U)
+ .I NAM="" S NAM=SUB
+ .S ^TMP($J,"SORT",NAM)=SUB
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m

@@ -1 @@
-PXRMXPR1        ; SLC/AGP - Print Reminder Due report carryover code. ;01/05/2006
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Patient list display
-FOOTER(PLSTCRIT)        ;
-        N CNT,CNT1,COUNT,TEXT
-        ;Count patients in list
-        S COUNT=+$O(^PXRMXP(810.5,PXRMLIS1,30,"A"),-1)
-        ;
-        I COUNT=0 W !!!,"No patients due. Patient List not created" Q
-        W !!!,"Patient List "_$P($G(^PXRMXP(810.5,PXRMLIS1,0)),U)_" created by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($P($G(^PXRMXP(810.5,PXRMLIS1,0)),U,4),1)
-        W !!,"List contains "_COUNT_" patients, report run on "_TTOTAL_" patients."
-        ;
-        ;Screen out formatting lines and second piece of criteria array
-        S (CNT,CNT1)=0 F  S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0  D
-        .I $P($G(PLSTCRIT(CNT)),U)="",$P($G(PLSTCRIT(CNT)),U,2)>0 Q
-        .S CNT1=CNT1+1 S TEXT(CNT1)=$P($G(PLSTCRIT(CNT)),U)
-        ;Store Report Criteria in the document multiple of the patient list
-        F CNT1=1:1:CNT1 S ^PXRMXP(810.5,PXRMLIS1,200,CNT1,0)=TEXT(CNT1)
-        S ^PXRMXP(810.5,PXRMLIS1,200,0)=U_"810.51"_U_CNT1_U_CNT1
-        Q
-        ;
-        ;Set up literals for display
-LITS    ;
-        I PXRMSEL="I" S PXRMFLD="Individual Patients"
-        I PXRMSEL="R" S PXRMFLD="Patient List"
-        I PXRMSEL="P" S PXRMFLD="PCMM Provider"
-        I PXRMSEL="O" S PXRMFLD="OE/RR Team"
-        I PXRMSEL="T" S PXRMFLD="PCMM Team"
-        I PXRMSEL="L" D
-        .S PXRMFLD="Location"
-        .I $P(PXRMLCSC,U)="HS" S DES="Selected Hospital Locations"
-        .I $P(PXRMLCSC,U)="HA" S DES="All Outpatient Locations"
-        .I $P(PXRMLCSC,U)="HAI" S DES="All Inpatient Locations"
-        .I $P(PXRMLCSC,U)="CS" S DES="Selected Clinic Stops"
-        .I $P(PXRMLCSC,U)="CA" S DES="All Clinic Stops"
-        .I $P(PXRMLCSC,U)="GS" S DES="Selected Clinic Groups"
-        .I PXRMFD="P" S DES=DES_" (Prior Encounters)"
-        .I PXRMFD="F" S DES=DES_" (Future Appoints.)"
-        .I PXRMFD="A" S DES=DES_" (Admissions)"
-        .I PXRMFD="C" S DES=DES_" (Current Inpatients)"
-        I PXRMSEL="P" D
-        .I PXRMPRIM="A" S CDES="All patients on list"
-        .I PXRMPRIM="P" S CDES="Primary care assigned patients only"
-        Q
-        ;
-        ;Report missed locations if report is partially successful
-MISSED(PSTART,MISSED)   ;
-        ;Delimited report from template
-        I PXRMTABS="Y",PXRMTMP'="" D  Q
-        .W !!?PSTART,"The following had no patients selected",!
-        .N SUB
-        .S SUB=""
-        .F  S SUB=$O(MISSED(SUB)) Q:SUB=""  D
-        ..W !?PSTART+10,SUB
-        ;Other reports
-        N LIT,SUB
-        D CHECK^PXRMXGPR(5) Q:DONE
-        S LIT=PXRMFLD
-        I PXRMSEL="L",$E(PXRMLCSC)="G" S LIT="Clinic Group"
-        W !!?PSTART,"The following ",LIT,"(s) had no patients selected",!
-        S SUB=""
-        F  S SUB=$O(MISSED(SUB)) Q:SUB=""  D
-        .D CHECK^PXRMXGPR(3) Q:DONE
-        .W !?PSTART+10,SUB
-        Q
-        ;
-        ;Build array of locations/providers/teams with no patients
-NOPATS(MISSED)  ;
-        N DATA,IC,LTYPE,MARK
-        S IC=""
-        I PXRMSEL="P" D  Q
-        . F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D
-        .. S DATA=PXRMPRV(IC)
-        .. D TEST(DATA,$P(DATA,U,1),.MISSED)
-        I PXRMSEL="T" D
-        . F  S IC=$O(PXRMPCM(IC)) Q:IC=""  D
-        .. S DATA=PXRMPCM(IC)
-        .. D TEST(DATA,$P(DATA,U,1),.MISSED)
-        I PXRMSEL="O" D
-        . F  S IC=$O(PXRMOTM(IC)) Q:IC=""  D
-        .. S DATA=PXRMOTM(IC)
-        .. D TEST(DATA,$P(DATA,U,1),.MISSED)
-        S LTYPE=$E($G(PXRMLCSC))
-        I LTYPE="H" D
-        . F  S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC=""  D
-        .. S DATA=^XTMP(PXRMXTMP,"HLOC",IC)
-        .. D TEST(DATA,IC,.MISSED)
-        I LTYPE="C" D
-        . F  S IC=$O(PXRMCS(IC)) Q:IC=""  D
-        .. S DATA=PXRMCS(IC)
-        .. D TEST(DATA,$P(DATA,U,3),.MISSED)
-        I LTYPE="G" D
-        . F  S IC=$O(PXRMCGRP(IC)) Q:IC=""  D
-        .. S DATA=PXRMCGRP(IC)
-        .. D TEST(DATA,$P(DATA,U,1),.MISSED)
-        Q
-        ;
-        ;Check for match on location
-TEST(DATA,IEN,MISSED)   ;
-        N SUB
-        I $D(^XTMP(PXRMXTMP,"MARKED AS FOUND",IEN)) Q
-        I PXRMSEL'="L" S MISSED($P(DATA,U,2))="" Q
-        N LTYPE
-        S LTYPE=$E(PXRMLCSC)
-        I LTYPE="H" S SUB=IEN D
-        . N FACNAM,FACNUM,HLOC
-        . S HLOC=$P(DATA,U,2) Q:HLOC=""
-        . S FACNUM=$$HFAC^PXRMXSL1(IEN)
-        . S FACNAM=$S(FACNUM="":"?",1:$P($G(PXRMFACN(FACNUM)),U,1))
-        . I FACNAM'="" S SUB=HLOC_" ("_FACNAM_")"
-        I LTYPE="C" S SUB=$P(DATA,U,1)_" "_$P(DATA,U,3)
-        I LTYPE="G" S SUB=$P(DATA,U,2)
-        S MISSED(SUB)=""
-        Q
-        ;
+PXRMXPR1 ; SLC/AGP - Print Reminder Due report carryover code. ;01/05/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Patient list display
+FOOTER(PLSTCRIT) ;
+ N CNT,CNT1,COUNT,TEXT
+ ;Count patients in list
+ S COUNT=+$O(^PXRMXP(810.5,PXRMLIS1,30,"A"),-1)
+ ;
+ I COUNT=0 W !!!,"No patients due. Patient List not created" Q
+ W !!!,"Patient List "_$P($G(^PXRMXP(810.5,PXRMLIS1,0)),U)_" created by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($P($G(^PXRMXP(810.5,PXRMLIS1,0)),U,4),1)
+ W !!,"List contains "_COUNT_" patients, report run on "_TTOTAL_" patients."
+ ;
+ ;Screen out formatting lines and second piece of criteria array
+ S (CNT,CNT1)=0 F  S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0  D
+ .I $P($G(PLSTCRIT(CNT)),U)="",$P($G(PLSTCRIT(CNT)),U,2)>0 Q
+ .S CNT1=CNT1+1 S TEXT(CNT1)=$P($G(PLSTCRIT(CNT)),U)
+ ;Store Report Criteria in the document multiple of the patient list
+ F CNT1=1:1:CNT1 S ^PXRMXP(810.5,PXRMLIS1,200,CNT1,0)=TEXT(CNT1)
+ S ^PXRMXP(810.5,PXRMLIS1,200,0)=U_"810.51"_U_CNT1_U_CNT1
+ Q
+ ;
+ ;Set up literals for display
+LITS ;
+ I PXRMSEL="I" S PXRMFLD="Individual Patients"
+ I PXRMSEL="R" S PXRMFLD="Patient List"
+ I PXRMSEL="P" S PXRMFLD="PCMM Provider"
+ I PXRMSEL="O" S PXRMFLD="OE/RR Team"
+ I PXRMSEL="T" S PXRMFLD="PCMM Team"
+ I PXRMSEL="L" D
+ .S PXRMFLD="Location"
+ .I $P(PXRMLCSC,U)="HS" S DES="Selected Hospital Locations"
+ .I $P(PXRMLCSC,U)="HA" S DES="All Outpatient Locations"
+ .I $P(PXRMLCSC,U)="HAI" S DES="All Inpatient Locations"
+ .I $P(PXRMLCSC,U)="CS" S DES="Selected Clinic Stops"
+ .I $P(PXRMLCSC,U)="CA" S DES="All Clinic Stops"
+ .I $P(PXRMLCSC,U)="GS" S DES="Selected Clinic Groups"
+ .I PXRMFD="P" S DES=DES_" (Prior Encounters)"
+ .I PXRMFD="F" S DES=DES_" (Future Appoints.)"
+ .I PXRMFD="A" S DES=DES_" (Admissions)"
+ .I PXRMFD="C" S DES=DES_" (Current Inpatients)"
+ I PXRMSEL="P" D
+ .I PXRMPRIM="A" S CDES="All patients on list"
+ .I PXRMPRIM="P" S CDES="Primary care assigned patients only"
+ Q
+ ;
+ ;Report missed locations if report is partially successful
+MISSED(PSTART,MISSED) ;
+ ;Delimited report from template
+ I PXRMTABS="Y",PXRMTMP'="" D  Q
+ .W !!?PSTART,"The following had no patients selected",!
+ .N SUB
+ .S SUB=""
+ .F  S SUB=$O(MISSED(SUB)) Q:SUB=""  D
+ ..W !?PSTART+10,SUB
+ ;Other reports
+ N LIT,SUB
+ D CHECK^PXRMXGPR(5) Q:DONE
+ S LIT=PXRMFLD
+ I PXRMSEL="L",$E(PXRMLCSC)="G" S LIT="Clinic Group"
+ W !!?PSTART,"The following ",LIT,"(s) had no patients selected",!
+ S SUB=""
+ F  S SUB=$O(MISSED(SUB)) Q:SUB=""  D
+ .D CHECK^PXRMXGPR(3) Q:DONE
+ .W !?PSTART+10,SUB
+ Q
+ ;
+ ;Build array of locations/providers/teams with no patients
+NOPATS(MISSED) ;
+ N DATA,IC,LTYPE,MARK
+ S IC=""
+ I PXRMSEL="P" D
+ . F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D
+ .. S DATA=PXRMPRV(IC)
+ .. D TEST(DATA,$P(DATA,U,1),.MISSED)
+ I PXRMSEL="T" D
+ . F  S IC=$O(PXRMPCM(IC)) Q:IC=""  D
+ .. S DATA=PXRMPCM(IC)
+ .. D TEST(DATA,$P(DATA,U,1),.MISSED)
+ I PXRMSEL="O" D
+ . F  S IC=$O(PXRMOTM(IC)) Q:IC=""  D
+ .. S DATA=PXRMOTM(IC)
+ .. D TEST(DATA,$P(DATA,U,1),.MISSED)
+ S LTYPE=$E($G(PXRMLCSC))
+ I LTYPE="H" D
+ . F  S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC=""  D
+ .. S DATA=^XTMP(PXRMXTMP,"HLOC",IC)
+ .. D TEST(DATA,IC,.MISSED)
+ I LTYPE="C" D
+ . F  S IC=$O(PXRMCS(IC)) Q:IC=""  D
+ .. S DATA=PXRMCS(IC)
+ .. D TEST(DATA,$P(DATA,U,3),.MISSED)
+ I LTYPE="G" D
+ . F  S IC=$O(PXRMCGRP(IC)) Q:IC=""  D
+ .. S DATA=PXRMCGRP(IC)
+ .. D TEST(DATA,$P(DATA,U,1),.MISSED)
+ Q
+ ;
+ ;Check for match on location
+TEST(DATA,IEN,MISSED) ;
+ N SUB
+ I $D(^XTMP(PXRMXTMP,"MARKED AS FOUND",IEN)) Q
+ I PXRMSEL'="L" S MISSED($P(DATA,U,2))="" Q
+ N LTYPE
+ S LTYPE=$E(PXRMLCSC)
+ I LTYPE="H" S SUB=IEN D
+ . N FACNAM,FACNUM,HLOC
+ . S HLOC=$P(DATA,U,2) Q:HLOC=""
+ . S FACNUM=$$HFAC^PXRMXSL1(IEN)
+ . S FACNAM=$S(FACNUM="":"?",1:$P($G(PXRMFACN(FACNUM)),U,1))
+ . I FACNAM'="" S SUB=HLOC_" ("_FACNAM_")"
+ I LTYPE="C" S SUB=$P(DATA,U,1)_" "_$P(DATA,U,3)
+ I LTYPE="G" S SUB=$P(DATA,U,2)
+ S MISSED(SUB)=""
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m

@@ -1 @@
-PXRMXQUE        ; SLC/PJH - Reminder reports general queuing routine.;03/23/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ;Determine whether the report should be queued.
-JOB     ;
-        N %ZIS S %ZIS="Q"
-        W !
-        D ^%ZIS
-        I POP G EXIT^PXRMXD
-        S PXRMIOD=ION_";"_IOST_";"_IOM_";"_IOSL
-        S PXRMQUE=$G(IO("Q"))
-        ;
-        I PXRMQUE D  Q
-        . ;Queue the report.
-        . N DESC,PXRMIOV,ROUTINE,TASK,ZTDTH
-        . S DESC="Reminder Due Report - sort"
-        . S PXRMIOV=""
-        . S ROUTINE="^PXRMXSE1"
-        . M ^TMP("PXRM-MESS",$J)=^TMP("XM-MESS",$J)
-        . S TASK=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE") Q:TASK=""
-        . S ^XTMP(PXRMXTMP,"SORTZTSK")=TASK
-        . M ^TMP("XM-MESS",$J)=^TMP("PXRM-MESS",$J)
-        . K ^TMP("PXRM-MESS",$J)
-        .;
-        . S DESC="Reminder Due Report - print"
-        . S PXRMIOV=PXRMIOD
-        . S ROUTINE="^PXRMXPR"
-        . S ZTDTH="@"
-        . S ^XTMP(PXRMXTMP,"PRZTSK")=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE")
-        I 'PXRMQUE D ^PXRMXSE1
-        Q
-        ;
-QUE(DESC,PXRMIOV,ROUTINE,SAVE)  ;Queue a task.
-        N ZTDESC,ZTIO,ZTRTN,ZTSAVE
-        D @SAVE
-        S ZTDESC=DESC
-        S ZTIO=PXRMIOV
-        S ZTRTN=ROUTINE
-        D ^%ZTLOAD
-        I $D(ZTSK)=0 W !!,DESC," cancelled"
-        E  W !!,DESC," has been queued, task number ",ZTSK
-        Q $G(ZTSK)
-        ;
-DEVICE(RTN,DESC,SAVE,%ZIS,RETZTSK)      ;
-        ;Pass RETZTSK as number such as 1 if you want to get ZTSK.
-        N ZTSK
-        W !
-        D EN^XUTMDEVQ(RTN,DESC,.SAVE,.%ZIS,RETZTSK)
-        I $D(ZTSK) W !!,DESC," has been queued, task number "_ZTSK H 2
-        Q $G(ZTSK)
-        ;
-        ;=======================================================================
-REQUE(DESC,ROUTINE,TASK)        ;Reque a task.
-        N ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTSK
-        S ZTDESC=DESC
-        S ZTRTN=ROUTINE
-        S ZTSK=TASK
-        S ZTDTH=$$NOW^XLFDT
-        D REQ^%ZTLOAD
-        I ZTSK(0)=1 Q
-        ;There was a problem, send an error message.
-        K ZTSK S ZTSK=TASK
-        D ISQED^%ZTLOAD
-        N LC,SUB
-        K ^TMP("PXRMXMZ",$J)
-        S ^TMP("PXRMXMZ",$J,1,0)="Could not start the print task, task information:"
-        S ^TMP("PXRMXMZ",$J,2,0)=" Task number "_TASK
-        S LC=2,SUB=""
-        F  S SUB=$O(ZTSK(SUB)) Q:SUB=""  D
-        . S LC=LC+1
-        . S ^TMP("PXRMXMZ",$J,LC,0)=" ZTSK("_SUB_")="_ZTSK(SUB)
-        S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Print start time="_ZTDTH
-        S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Submit time="_$P(PXRMXTMP,"PXRMX",2)
-        S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)="PXRMXTMP="_$G(PXRMXTMP)
-        D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ)
-        Q
-        ;
-        ;=======================================================================
-SAVE    ;Save the variables for queing.
-        S ZTSAVE("PXRMBDT")="",ZTSAVE("PXRMEDT")="",ZTSAVE("PXRMSDT")=""
-        S ZTSAVE("PXRMCS(")="",ZTSAVE("NCS")=""
-        S ZTSAVE("PXRMCGRP(")="",ZTSAVE("NCGRP")=""
-        S ZTSAVE("PXRMFAC(")="",ZTSAVE("NFAC")=""
-        S ZTSAVE("PXRMFACN(")=""
-        S ZTSAVE("PXRMFCMB")=""
-        S ZTSAVE("PXRMFUT")="",ZTSAVE("PXRMDLOC")=""
-        S ZTSAVE("PXRMFD")=""
-        S ZTSAVE("PXRMINP")=""
-        S ZTSAVE("PXRMIOD")=""
-        S ZTSAVE("PXRMLCHL(")="",ZTSAVE("NHL")=""
-        S ZTSAVE("PXRMLCMB")=""
-        S ZTSAVE("PXRMLCSC")=""
-        S ZTSAVE("PXRMPRIM")=""
-        S ZTSAVE("PXRMQUE")=""
-        S ZTSAVE("PXRMREP")=""
-        S ZTSAVE("PXRMRT")=""
-        S ZTSAVE("PXRMSCAT")="",ZTSAVE("PXRMSCAT(")=""
-        S ZTSAVE("PXRMSEL")=""
-        S ZTSAVE("PXRMSRT")=""
-        S ZTSAVE("PXRMSSN")=""
-        S ZTSAVE("PXRMTABC")=""
-        S ZTSAVE("PXRMTABS")=""
-        S ZTSAVE("PXRMTCMB")=""
-        S ZTSAVE("PXRMTMP")=""
-        S ZTSAVE("PXRMTOT")=""
-        S ZTSAVE("PXRMXTMP")=""
-        ; Time initiated
-        S ZTSAVE("PXRMXST")=""
-        ; New selection criteria
-        S ZTSAVE("PXRMOTM(")="",ZTSAVE("NOTM")=""
-        S ZTSAVE("PXRMPRV(")="",ZTSAVE("NPRV")=""
-        S ZTSAVE("PXRMPAT(")="",ZTSAVE("NPAT")=""
-        S ZTSAVE("PXRMPCM(")="",ZTSAVE("NPCM")=""
-        S ZTSAVE("PXRMREM(")="",ZTSAVE("NREM")=""
-        S ZTSAVE("PXRMRCAT(")="",ZTSAVE("NCAT")=""
-        S ZTSAVE("PXRMUSER")=""
-        ;Reminder list
-        S ZTSAVE("REMINDER(")=""
-        ; Arrays by IEN
-        S ZTSAVE("PXRMLOCN(")=""
-        S ZTSAVE("PXRMCSN(")=""
-        S ZTSAVE("PXRMCGRN(")=""
-        ;Patient List
-        S ZTSAVE("PATCREAT")=""
-        S ZTSAVE("PATLST")=""
-        S ZTSAVE("PXRMLIST(")=""
-        S ZTSAVE("PXRMLIS1")=""
-        S ZTSAVE("PLISTPUG")=""
-        ;User DUZ
-        S ZTSAVE("DBDUZ")=""
-        S ZTSAVE("DBERR")=""
-        S ZTSAVE("PXRMRERR(")=""
-        ;Dubug information
-        S ZTSAVE("PXRMDBUG")=""
-        S ZTSAVE("PXRMDBUS")=""
-        ;Patient Information
-        S ZTSAVE("PXRMTPAT")=""
-        S ZTSAVE("PXRMDPAT")=""
-        I +$G(PXRMIDOD)>0 S ZTSAVE("PXRMIDOD")=""
-        S ZTSAVE("PXRMPML")=""
-        Q
+PXRMXQUE ; SLC/PJH - Reminder reports general queuing routine.;02/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+        ;Determine whether the report should be queued.
+JOB ;
+ N %ZIS S %ZIS="Q"
+ W !
+ D ^%ZIS
+ I POP G EXIT^PXRMXD
+ S PXRMIOD=ION_";"_IOST_";"_IOM_";"_IOSL
+ S PXRMQUE=$G(IO("Q"))
+ ;
+ I PXRMQUE D  Q
+ . ;Queue the report.
+ . N DESC,PXRMIOV,ROUTINE,TASK,ZTDTH
+ . S DESC="Reminder Due Report - sort"
+ . S PXRMIOV=""
+ . S ROUTINE="^PXRMXSE1"
+ . M ^TMP("PXRM-MESS",$J)=^TMP("XM-MESS",$J)
+ . S TASK=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE") Q:TASK=""
+ . S ^XTMP(PXRMXTMP,"SORTZTSK")=TASK
+ . M ^TMP("XM-MESS",$J)=^TMP("PXRM-MESS",$J)
+ . K ^TMP("PXRM-MESS",$J)
+ .;
+ . S DESC="Reminder Due Report - print"
+ . S PXRMIOV=PXRMIOD
+ . S ROUTINE="^PXRMXPR"
+ . S ZTDTH="@"
+ . S ^XTMP(PXRMXTMP,"PRZTSK")=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE")
+ I 'PXRMQUE D ^PXRMXSE1
+ Q
+ ;
+QUE(DESC,PXRMIOV,ROUTINE,SAVE) ;Queue a task.
+ N ZTDESC,ZTIO,ZTRTN,ZTSAVE
+ D @SAVE
+ S ZTDESC=DESC
+ S ZTIO=PXRMIOV
+ S ZTRTN=ROUTINE
+ D ^%ZTLOAD
+ I $D(ZTSK)=0 W !!,DESC," cancelled"
+ E  W !!,DESC," has been queued, task number ",ZTSK
+ Q $G(ZTSK)
+ ;
+DEVICE(ZTRTN,ZTDESC,ZTSAVE,%ZIS,ZTSK) ;
+ W !
+ D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
+ I $D(ZTSK)>1 W !!,ZTDESC," has been queued, task number "_$G(ZTSK) H 2
+ I $G(ZTSK)="" S ZTSK=0
+ Q ZTSK
+ ;
+ ;=======================================================================
+REQUE(DESC,ROUTINE,TASK) ;Reque a task.
+ N ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTSK
+ S ZTDESC=DESC
+ S ZTRTN=ROUTINE
+ S ZTSK=TASK
+ S ZTDTH=$$NOW^XLFDT
+ D REQ^%ZTLOAD
+ I ZTSK(0)=1 Q
+ ;There was a problem, send an error message.
+ K ZTSK S ZTSK=TASK
+ D ISQED^%ZTLOAD
+ N LC,SUB
+ K ^TMP("PXRMXMZ",$J)
+ S ^TMP("PXRMXMZ",$J,1,0)="Could not start the print task, task information:"
+ S ^TMP("PXRMXMZ",$J,2,0)=" Task number "_TASK
+ S LC=2,SUB=""
+ F  S SUB=$O(ZTSK(SUB)) Q:SUB=""  D
+ . S LC=LC+1
+ . S ^TMP("PXRMXMZ",$J,LC,0)=" ZTSK("_SUB_")="_ZTSK(SUB)
+ S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Print start time="_ZTDTH
+ S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Submit time="_$P(PXRMXTMP,"PXRMX",2)
+ S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)="PXRMXTMP="_$G(PXRMXTMP)
+ D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ)
+ Q
+ ;
+ ;=======================================================================
+SAVE ;Save the variables for queing.
+ S ZTSAVE("PXRMBDT")="",ZTSAVE("PXRMEDT")="",ZTSAVE("PXRMSDT")=""
+ S ZTSAVE("PXRMCS(")="",ZTSAVE("NCS")=""
+ S ZTSAVE("PXRMCGRP(")="",ZTSAVE("NCGRP")=""
+ S ZTSAVE("PXRMFAC(")="",ZTSAVE("NFAC")=""
+ S ZTSAVE("PXRMFACN(")=""
+ S ZTSAVE("PXRMFCMB")=""
+ S ZTSAVE("PXRMFUT")="",ZTSAVE("PXRMDLOC")=""
+ S ZTSAVE("PXRMFD")=""
+ S ZTSAVE("PXRMINP")=""
+ S ZTSAVE("PXRMIOD")=""
+ S ZTSAVE("PXRMLCHL(")="",ZTSAVE("NHL")=""
+ S ZTSAVE("PXRMLCMB")=""
+ S ZTSAVE("PXRMLCSC")=""
+ S ZTSAVE("PXRMPRIM")=""
+ S ZTSAVE("PXRMQUE")=""
+ S ZTSAVE("PXRMREP")=""
+ S ZTSAVE("PXRMRT")=""
+ S ZTSAVE("PXRMSCAT")="",ZTSAVE("PXRMSCAT(")=""
+ S ZTSAVE("PXRMSEL")=""
+ S ZTSAVE("PXRMSRT")=""
+ S ZTSAVE("PXRMSSN")=""
+ S ZTSAVE("PXRMTABC")=""
+ S ZTSAVE("PXRMTABS")=""
+ S ZTSAVE("PXRMTCMB")=""
+ S ZTSAVE("PXRMTMP")=""
+ S ZTSAVE("PXRMTOT")=""
+ S ZTSAVE("PXRMXTMP")=""
+ ; Time initiated
+ S ZTSAVE("PXRMXST")=""
+ ; New selection criteria
+ S ZTSAVE("PXRMOTM(")="",ZTSAVE("NOTM")=""
+ S ZTSAVE("PXRMPRV(")="",ZTSAVE("NPRV")=""
+ S ZTSAVE("PXRMPAT(")="",ZTSAVE("NPAT")=""
+ S ZTSAVE("PXRMPCM(")="",ZTSAVE("NPCM")=""
+ S ZTSAVE("PXRMREM(")="",ZTSAVE("NREM")=""
+ S ZTSAVE("PXRMRCAT(")="",ZTSAVE("NCAT")=""
+ S ZTSAVE("PXRMUSER")=""
+ ;Reminder list
+ S ZTSAVE("REMINDER(")=""
+ ; Arrays by IEN
+ S ZTSAVE("PXRMLOCN(")=""
+ S ZTSAVE("PXRMCSN(")=""
+ S ZTSAVE("PXRMCGRN(")=""
+ ;Patient List
+ S ZTSAVE("PATCREAT")=""
+ S ZTSAVE("PATLST")=""
+ S ZTSAVE("PXRMLIST(")=""
+ S ZTSAVE("PXRMLIS1")=""
+ S ZTSAVE("PLISTPUG")=""
+ ;User DUZ
+ S ZTSAVE("DBDUZ")=""
+ S ZTSAVE("DBERR")=""
+ S ZTSAVE("PXRMRERR(")=""
+ ;Dubug information
+ S ZTSAVE("PXRMDBUG")=""
+ S ZTSAVE("PXRMDBUS")=""
+ ;Patient Information
+ S ZTSAVE("PXRMTPAT")=""
+ S ZTSAVE("PXRMDPAT")=""
+ I +$G(PXRMIDOD)>0 S ZTSAVE("PXRMIDOD")=""
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m

@@ -1 @@
-PXRMXSC ; SLC/PJH - Reminder reports service category selection ;12/18/2006
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-SCAT    ;Get the list of service categories.
-        N DIR,DIEA,IC,JC,NSC,PCESVC,SCA,VALID,X,Y
-        K DIRUT,DTOUT,DUOUT
-        ;Build a list of allowed service categories. PCE uses a subset of the
-        ;categories in the file.  These are stored in PCESVC.
-        S PCESVC=""
-        D HELP^DIE(9000010,"",.07,"S","SCA")
-        S NSC=SCA("DIHELP")
-        S DIR("?")=U_"D SCATHELP^PXRMXSC"
-        S DIR("??")=U_"D SCATHELP^PXRMXSC"
-SCATP   ;
-        S DIR(0)="FU"_U_"1:"_NSC
-        S DIR("A")="Select SERVICE CATEGORIES"
-        S DIR("B")="A,I"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        ;Make sure we have a valid list.
-        S VALID=$$VSCLIST(Y,PCESVC)
-        I 'VALID G SCATP
-        S PXRMSCAT=$$UP^XLFSTR(Y)
-        F IC=1:1:$L(PXRMSCAT,",") S X=$P(PXRMSCAT,",",IC),PXRMSCAT(X)=""
-        Q
-        ;
-        ;======================================================
-SCATHELP        ;? help for service categories.
-        N ARRAY,IC,JC,NSC,PCESVC
-        S PCESVC=""
-        D HELP^DIE(9000010,"",.07,"S","SCA")
-        S NSC=SCA("DIHELP")
-        S JC=0
-        F IC=2:1:NSC D
-        . S X=$P(SCA("DIHELP",IC)," ",1)
-        . I PCESVC="" S PCESVC=X
-        . E  S PCESVC=PCESVC_","_X
-        . S JC=JC+1
-        . S ARRAY(JC)=SCA("DIHELP",IC)
-        S NSC=JC
-        W !!,"Enter the letter(s), separated by commas, corresponding to the desired service"
-        W !,"category or categories. For example A,H,T,E would allow only encounters with"
-        W !,"service categories of ambulatory, hospitalization, telecommunications, and"
-        W !,"event (historical) to be included."
-        W !!,"The possible service categories for the report are:",!
-        F IC=1:1:NSC W !,ARRAY(IC)
-        Q
-        ;
-        ;======================================================
-VSCLIST(LIST,SLIST)     ;LIST is a comma separated list of service categories. SLIST
-        ;is the standard list of service categories. Make sure all the
-        ;elements of LIST are in the standard list SLIST. If they are, then
-        ;LIST is valid. Used for selection in reminder reports and as input
-        ;transform SERVICE CATEGORY LIST in the REMINDER REPORT TEMPLATE
-        ;file #810.1.
-        I LIST="" Q 1
-        I $G(SLIST)="" D
-        . N IC,SCA,TEMP
-        . D HELP^DIE(9000010,"",.07,"S","SCA")
-        . S SLIST=""
-        . F IC=2:1:SCA("DIHELP") D
-        .. S TEMP=$P(SCA("DIHELP",IC)," ",1)
-        .. I SLIST="" S SLIST=TEMP
-        .. E  S SLIST=SLIST_","_TEMP
-        N IC,LE,LEN,VALID
-        S LIST=$$UP^XLFSTR(LIST)
-        S VALID=1
-        S LEN=$L(LIST,",")
-        F IC=1:1:LEN D
-        . S LE=$P(LIST,",",IC)
-        . I LE="" D  Q
-        .. D EN^DDIOL("Null is not a valid service category!")
-        .. S VALID=0
-        . I SLIST'[LE D
-        .. D EN^DDIOL(LE_" is an invalid service category!")
-        .. S VALID=0
-        Q VALID
-        ;
+PXRMXSC ; SLC/PJH - Reminder reports service category selection ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+SCAT ;Get the list of service categories.
+ N DIR,DIEA,IC,JC,NSC,PCESVC,SCA,VALID,X,Y
+ K DIRUT,DTOUT,DUOUT
+ ;Build a list of allowed service categories. PCE uses a subset of the
+ ;categories in the file.  These are stored in PCESVC.
+ S PCESVC=""
+ D HELP^DIE(9000010,"",.07,"S","SCA")
+ S NSC=SCA("DIHELP")
+ S DIR("?")=" "
+ S DIR("?",1)="The possible service categories for the report are:"
+ S JC=0
+ F IC=2:1:NSC D
+ . S X=$P(SCA("DIHELP",IC)," ",1)
+ . I PCESVC="" S PCESVC=X
+ . E  S PCESVC=PCESVC_","_X
+ . S JC=JC+1
+ . S DIR("?",JC)=SCA("DIHELP",IC)
+ S NSC=JC
+ S DIR("??")=U_"D SCATHELP^PXRMXSC"
+SCATP ;
+ S DIR(0)="FU"_U_"1:"_NSC
+ S DIR("A")="Select SERVICE CATEGORIES"
+ S DIR("B")="A,I"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ ;Make sure we have a valid list.
+ S VALID=$$VSCLIST(Y,PCESVC)
+ I 'VALID G SCATP
+ S PXRMSCAT=$$UP^XLFSTR(Y)
+ F IC=1:1:$L(PXRMSCAT,",") S X=$P(PXRMSCAT,",",IC),PXRMSCAT(X)=""
+ Q
+ ;
+ ;======================================================
+SCATHELP ;?? help for service categories.
+ W !!,"Enter the letter(s), separated by commas, corresponding to the desired service"
+ W !,"category or categories. For example A,H,T,E would allow only encounters with"
+ W !,"service categories of ambulatory, hospitalization, telecommunications, and"
+ W !,"event (historical) to be included."
+ Q
+ ;
+ ;======================================================
+VSCLIST(LIST,SLIST) ;LIST is a comma separated list of service categories. SLIST
+ ;is the standard list of service categories. Make sure all the
+ ;elements of LIST are in the standard list SLIST. If they are, then
+ ;LIST is valid. Used for selection in reminder reports and as input
+ ;transform SERVICE CATEGORY LIST in the REMINDER REPORT TEMPLATE
+ ;file #810.1.
+ I LIST="" Q 1
+ I $G(SLIST)="" D
+ . N IC,SCA,TEMP
+ . D HELP^DIE(9000010,"",.07,"S","SCA")
+ . S SLIST=""
+ . F IC=2:1:SCA("DIHELP") D
+ .. S TEMP=$P(SCA("DIHELP",IC)," ",1)
+ .. I SLIST="" S SLIST=TEMP
+ .. E  S SLIST=SLIST_","_TEMP
+ N IC,LE,LEN,VALID
+ S LIST=$$UP^XLFSTR(LIST)
+ S VALID=1
+ S LEN=$L(LIST,",")
+ F IC=1:1:LEN D
+ . S LE=$P(LIST,",",IC)
+ . I LE="" D  Q
+ .. D EN^DDIOL("Null is not a valid service category!")
+ .. S VALID=0
+ . I SLIST'[LE D
+ .. D EN^DDIOL(LE_" is an invalid service category!")
+ .. S VALID=0
+ Q VALID
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m

@@ -1 @@
-PXRMXSE1        ; SLC/PJH - Build Patient lists for Reminder Due report; 08/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ; Called/jobbed from PXRMXD
-        ;
-        ; Input - PXRMSEL,PXRMXTMP
-        ;         PXRM*
-        ; Output- ^XTMP(PXRMXTMP
-        ;
-        ;
-START   ;  
-        N LIT,TOTAL,TODAY,ZTSTOP,BUSY
-        S DBDOWN=0
-        S TOTAL=0,ZTSTOP="",TODAY=$$DT^XLFDT-.0001
-        ;
-        K ^TMP($J,"PXRM PATIENT LIST"),^TMP($J,"PXRM PATIENT EVAL")
-        K ^TMP($J,"PXRM FUTURE APPT"),^TMP($J,"SDAMA301")
-        K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
-        K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J)
-        N PXRMRERR
-        ;
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        ;
-        ;OE/RR team selected (PXRMOTM)
-        I PXRMSEL="O" D OERR^PXRMXSL1
-        ; 
-        ;PCMM team selected (PXRMPCM)
-        I PXRMSEL="T" D PCMMT^PXRMXSL1
-        ;
-        N HLIEN,FACILITY
-        ;Location selected (PXRMLCHL,PXRMCGRP)
-        I PXRMSEL="L" D  G:ZTSTOP=1 EXIT
-        .;Build Clinic List
-        .D BHLOC^PXRMXSL1
-        .;Prior Visits - build patient list in ^TMP
-        .I PXRMFD="P" D VISITS^PXRMXSL2 I DBDOWN=1 Q
-        .;Inpatient Admissions and current inpatient locations
-        .I PXRMFD="A"!(PXRMFD="C") D INPADM^PXRMXSL1
-        .;Future Appointments - build patient list in ^TMP
-        .I PXRMFD="F" D APPTS^PXRMXSL2 I DBDOWN=1 Q
-        .;End task requested
-        .Q:ZTSTOP=1
-        ;Update ^XTMP from ^TMP
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        ;
-        ;PCMM provider selected (PXRMPRV)
-        I PXRMSEL="P" D PCMMP^PXRMXSL1
-        ;
-        ;Individual Patients selected (PXRMPAT)
-        I PXRMSEL="I" D IND^PXRMXSL1
-        ;
-        ;Patient List selected (PXRMLIST)
-        I PXRMSEL="R" D LIST^PXRMXSL1
-        ;
-        I DBDOWN=1 G EXIT
-        S START=$H
-        D EVAL^PXRMXEVL("PXRM PATIENT EVAL",.REMINDER)
-        D XTMP(START)
-        ;
-        ;Update patient list
-        I PXRMSEL'="I"&(PXRMUSER'="Y")&($G(PXRMLIS1)'="") D
-        .;If no patients due delete patient list
-        .I +$O(^TMP($J,"PXRMXPAT",""))=0 D  Q
-        ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK
-        .;Otherwise create patient list
-        .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","","",PXRMDPAT,PXRMTPAT)
-        .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1
-        K ^TMP($J,"PXRMXPAT")
-        K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
-        K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J),^TMP("PXRMCMB3",$J)
-        K DBDOWN
-        ;
-DONE    ;
-        ;Sorting is done.
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W ! D DONE^PXRMXBSY("done")
-        ;
-        ;I PXRMDBUG="Y" D DEBUG("End of evaluation:",PXRMREP,"^XTMP(PXRMXTMP,PX)")
-        ;Print the report information.
-        I PXRMQUE D  Q
-        .;Start the printing that was queued but not scheduled.
-        .N DESC,ROUTINE,TASK
-        .S ROUTINE="^PXRMXPR"
-        .S DESC="Reminder Due Report - print"
-        .S TASK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
-        .I TASK="" D NOPRZTSK(PXRMXTMP) Q
-        .D REQUE^PXRMXQUE(DESC,ROUTINE,TASK)
-        .S ZTREQ="@"
-        I 'PXRMQUE D ^PXRMXPR
-        Q
-        ;
-AWRITE(REF,LS)      ;This line tag is a copy of AWRITE^PXRMUTIL
-        N CNT,DONE,IC,IND,LEN,PROOT,ROOT,START,TEMP
-        I REF="" Q
-        S PROOT=$P(REF,")",1)
-        S TEMP=$NA(@REF)
-        S ROOT=$P(TEMP,")",1)
-        S REF=$Q(@REF)
-        I REF'[ROOT Q
-        S DONE=0,CNT=LS
-        F IC=0:0 Q:(REF="")!(DONE)  D
-        . S START=$F(REF,ROOT)
-        . S LEN=$L(REF)
-        . S IND=$E(REF,START,LEN)
-        . S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)=PROOT_IND_"="_@REF
-        . S REF=$Q(@REF)
-        . I REF'[ROOT S DONE=1
-        Q
-        ;
-DEBUG(LOC,TYPE,REF)     ;
-        N CNT,DDAT,FACILITY,HEADER,PNAM,PX,SUB
-        K ^TMP("PXRMXMZ",$J)
-        S PX="PXRM"
-        I TYPE'="P"&(TYPE'="DEBUG") D  Q
-        .D AWRITE(REF,0)
-        .D SEND^PXRMMSG("Debug output: "_LOC_" Reminder Report type "_TYPE_" ("_$$NOW^XLFDT_")",DUZ)
-        D AWRITE(REF,0)
-        S HEADER=LOC_" ("_$$NOW^XLFDT_")"
-        D SEND^PXRMMSG("Debug output: "_HEADER,DUZ)
-        Q
-        ;
-ERROR(STATUS,ITEM)      ;
-        ;Create XTMP entry for Reminders that error out or could not be
-        ;determing on evaluation
-        N ERRNAME
-        S STATUS=$P(STATUS,U)
-        S ERRNAME=$P(^PXD(811.9,ITEM,0),U)
-        I $D(^XTMP(PXRMXTMP,STATUS,ERRNAME))>0,^XTMP(PXRMXTMP,STATUS,ERRNAME)>0 D
-        .S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=^XTMP(PXRMXTMP,STATUS,ERRNAME)+1
-        E  S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=1
-        Q
-        ;
-        ;End Task requested
-EXIT    ;
-        S ZTSK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
-        I ZTSK>0 D KILL^%ZTLOAD
-        D EXIT^PXRMXGUT
-        K DBDOWN
-        Q
-        ;
-NOPRZTSK(PXRMXTMP)            ;Could not get PRZTSK send an error message
-        N TEXT
-        K ^TMP("PXRMXMZ",$J)
-        S TEXT(1,0)="The task number for the print job cannot be determined."
-        S TEXT(2,0)="The reason is:"
-        I '$D(^XTMP(PXRMXTMP)) S TEXT(3,0)=" The ^XTMP(PXRMXTMP) global is not defined."
-        I $D(^XTMP(PXRMXTMP)),'$D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XTMP(PXRMXTMP,""PRZTSK"") does not exist."
-        I $D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XMTP(PXRMXTMP,""PRZTSK"") is null."
-        S TEXT(4,0)="PXRMXTMP="_PXRMXTMP
-        M ^TMP("PXRMXMZ",$J)=TEXT
-        D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ)
-        Q
-        ;
-XTMP(START)     ;
-        N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME
-        N SUB,STATUS,TEMP,TEMP1,TEXT
-        K ^TMP($J,"PXRM CNBD")
-        S CCNT=0,MCNBD=$G(^PXRM(800,1,"MIERR")),MCNBDR=0
-        ;I PXRMDBUG="Y" D DEBUG("PATIENT DATA","P","^TMP($J,""PXRM PATIENT EVAL"")")
-        S BUSY=0,SUB="NAM",TEMP=0,PX="PXRM"
-        N DDAT,DDUE,DEMARR,DFN,DLAST,DNEXT,FACILITY,NAM,PNAM
-        S FACILITY="",DDAT="N/A"
-        F  S FACILITY=$O(^TMP(PXRMRT,$J,FACILITY)) Q:FACILITY=""  D
-        .S NAM=""
-        .F  S NAM=$O(^TMP(PXRMRT,$J,FACILITY,NAM)) Q:NAM=""  D
-        ..S DFN="" F  S DFN=$O(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) Q:DFN=""  D
-        ...I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Evaluating Reminders",.BUSY)
-        ...S INP=$G(^TMP(PXRMRT,$J,FACILITY,NAM,DFN))
-        ...S CNT=0 F  S CNT=$O(REMINDER(CNT)) Q:CNT'>0  D
-        ....S ITEM=$P(REMINDER(CNT),U,1),LIT=$P(REMINDER(CNT),U,4)
-        ....I LIT="" S LIT=$P(REMINDER(CNT),U,2)
-        ....S STATUS=$G(^TMP($J,"PXRM PATIENT EVAL",DFN,ITEM))
-        ....I STATUS="" Q
-        ....I STATUS["ERROR"!(STATUS["CNBD") D
-        .....D ERROR(STATUS,ITEM) I STATUS["ERROR"!(MCNBDR=1) Q
-        .....I CCNT=0 D  Q
-        ......S ^TMP($J,"PXRM CNBD",1,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR("PATIENT NAME",30)_$$RJ^XLFSTR("LAST 4",10)
-        ......S (TEMP,TEMP1)=""
-        ......F X=1:1:30 S TEMP=TEMP_"_"
-        ......F X=1:1:6 S TEMP1=TEMP1_"_"
-        ......S ^TMP($J,"PXRM CNBD",2,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(TEMP,30)_$$RJ^XLFSTR(TEMP1,10)
-        ......S CCNT=2
-        .....S CCNT=CCNT+1
-        .....I CCNT>MCNBD S MCNBDR=1 Q
-        .....S NAME=$P(^DPT(DFN,0),U)
-        .....S LSSN=$E($P(^DPT(DFN,0),U,9),6,9)
-        .....S ^TMP($J,"PXRM CNBD",CCNT,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(NAME,30)_$$RJ^XLFSTR(LSSN,10)
-        ....;Add reminder status to patient list TMP Global
-        ....I STATUS["DUE NOW" S ^TMP($J,"PXRMXPAT",DFN,"REM",ITEM)=ITEM_U_STATUS
-        ....I PXRMREP="D" D SDET^PXRMXDT1(DFN,STATUS,NAM,FACILITY,INP)
-        ....I PXRMREP="S" D SUM^PXRMXDT1(DFN,STATUS,FACILITY,NAM)
-        I $D(^TMP($J,"PXRM CNBD"))>0 D ERRMSG^PXRMXDT1("C")
-        K ^TMP($J,"PXRM CNBD")
-        S END=$H
-        S TEXT="Elapsed time for reminder evaluation: "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","REMINDER EVALUATION")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        ;I PXRMDBUG="Y" D DEBUG("DEBUG PATIENT DATA EVALUATION","DEBUG","^TMP($J,""PXRMDEBUG"")")
-        K ^TMP($J,"PXRM PATIENT EVAL")
-        Q
-        ;
+PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 01/25/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ; Called/jobbed from PXRMXD
+ ;
+ ; Input - PXRMSEL,PXRMXTMP
+ ;         PXRM*
+ ; Output- ^XTMP(PXRMXTMP
+ ;
+ ;
+START ;  
+ N LIT,TOTAL,TODAY,ZTSTOP,BUSY
+ S DBDOWN=0
+ S TOTAL=0,ZTSTOP="",TODAY=$$DT^XLFDT-.0001
+ ;
+ K ^TMP($J,"PXRM PATIENT LIST"),^TMP($J,"PXRM PATIENT EVAL")
+ K ^TMP($J,"PXRM FUTURE APPT"),^TMP($J,"SDAMA301")
+ K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
+ K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J)
+ N PXRMRERR
+ ;
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ ;
+ ;OE/RR team selected (PXRMOTM)
+ I PXRMSEL="O" D OERR^PXRMXSL1
+ ; 
+ ;PCMM team selected (PXRMPCM)
+ I PXRMSEL="T" D PCMMT^PXRMXSL1
+ ;
+ N HLIEN,FACILITY
+ ;Location selected (PXRMLCHL,PXRMCGRP)
+ I PXRMSEL="L" D  G:ZTSTOP=1 EXIT
+ .;Build Clinic List
+ .D BHLOC^PXRMXSL1
+ .;Prior Visits - build patient list in ^TMP
+ .I PXRMFD="P" D VISITS^PXRMXSL2 I DBDOWN=1 Q
+ .;Inpatient Admissions and current inpatient locations
+ .I PXRMFD="A"!(PXRMFD="C") D INPADM^PXRMXSL1
+ .;Future Appointments - build patient list in ^TMP
+ .I PXRMFD="F" D APPTS^PXRMXSL2 I DBDOWN=1 Q
+ .;End task requested
+ .Q:ZTSTOP=1
+ ;Update ^XTMP from ^TMP
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ ;
+ ;PCMM provider selected (PXRMPRV)
+ I PXRMSEL="P" D PCMMP^PXRMXSL1
+ ;
+ ;Individual Patients selected (PXRMPAT)
+ I PXRMSEL="I" D IND^PXRMXSL1
+ ;
+ ;Patient List selected (PXRMLIST)
+ I PXRMSEL="R" D LIST^PXRMXSL1
+ ;
+ I DBDOWN=1 G EXIT
+ S START=$H
+ D EVAL^PXRMXEVL("PXRM PATIENT EVAL",.REMINDER)
+ D XTMP(START)
+ ;
+ ;Update patient list
+ I PXRMSEL'="I"&(PXRMUSER'="Y")&($G(PXRMLIS1)'="") D
+ .;If no patients due delete patient list
+ .I +$O(^TMP($J,"PXRMXPAT",""))=0 D  Q
+ ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK
+ .;Otherwise create patient list
+ .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","")
+ .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1
+ K ^TMP($J,"PXRMXPAT")
+ K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J)
+ K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J),^TMP("PXRMCMB3",$J)
+ K DBDOWN
+ ;
+DONE ;
+ ;Sorting is done.
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W ! D DONE^PXRMXBSY("done")
+ ;
+ ;I PXRMDBUG="Y" D DEBUG("End of evaluation:",PXRMREP,"^XTMP(PXRMXTMP,PX)")
+ ;Print the report information.
+ I PXRMQUE D  Q
+ .;Start the printing that was queued but not scheduled.
+ .N DESC,ROUTINE,TASK
+ .S ROUTINE="^PXRMXPR"
+ .S DESC="Reminder Due Report - print"
+ .S TASK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
+ .I TASK="" D NOPRZTSK(PXRMXTMP) Q
+ .D REQUE^PXRMXQUE(DESC,ROUTINE,TASK)
+ .S ZTREQ="@"
+ I 'PXRMQUE D ^PXRMXPR
+ Q
+ ;
+AWRITE(REF,LS)     ;This line tag is a copy of AWRITE^PXRMUTIL
+ N CNT,DONE,IC,IND,LEN,PROOT,ROOT,START,TEMP
+ I REF="" Q
+ S PROOT=$P(REF,")",1)
+ S TEMP=$NA(@REF)
+ S ROOT=$P(TEMP,")",1)
+ S REF=$Q(@REF)
+ I REF'[ROOT Q
+ S DONE=0,CNT=LS
+ F IC=0:0 Q:(REF="")!(DONE)  D
+ . S START=$F(REF,ROOT)
+ . S LEN=$L(REF)
+ . S IND=$E(REF,START,LEN)
+ . S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)=PROOT_IND_"="_@REF
+ . S REF=$Q(@REF)
+ . I REF'[ROOT S DONE=1
+ Q
+ ;
+DEBUG(LOC,TYPE,REF) ;
+ N CNT,DDAT,FACILITY,HEADER,PNAM,PX,SUB
+ K ^TMP("PXRMXMZ",$J)
+ S PX="PXRM"
+ I TYPE'="P"&(TYPE'="DEBUG") D  Q
+ .D AWRITE(REF,0)
+ .D SEND^PXRMMSG("Debug output: "_LOC_" Reminder Report type "_TYPE_" ("_$$NOW^XLFDT_")",DUZ)
+ D AWRITE(REF,0)
+ S HEADER=LOC_" ("_$$NOW^XLFDT_")"
+ D SEND^PXRMMSG("Debug output: "_HEADER,DUZ)
+ Q
+ ;
+ERROR(STATUS,ITEM) ;
+ ;Create XTMP entry for Reminders that error out or could not be
+ ;determing on evaluation
+ N ERRNAME
+ S STATUS=$P(STATUS,U)
+ S ERRNAME=$P(^PXD(811.9,ITEM,0),U)
+ I $D(^XTMP(PXRMXTMP,STATUS,ERRNAME))>0,^XTMP(PXRMXTMP,STATUS,ERRNAME)>0 D
+ .S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=^XTMP(PXRMXTMP,STATUS,ERRNAME)+1
+ E  S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=1
+ Q
+ ;
+ ;End Task requested
+EXIT ;
+ S ZTSK=$G(^XTMP(PXRMXTMP,"PRZTSK"))
+ I ZTSK>0 D KILL^%ZTLOAD
+ D EXIT^PXRMXGUT
+ K DBDOWN
+ Q
+ ;
+NOPRZTSK(PXRMXTMP)       ;Could not get PRZTSK send an error message
+ N TEXT
+ K ^TMP("PXRMXMZ",$J)
+ S TEXT(1,0)="The task number for the print job cannot be determined."
+ S TEXT(2,0)="The reason is:"
+ I '$D(^XTMP(PXRMXTMP)) S TEXT(3,0)=" The ^XTMP(PXRMXTMP) global is not defined."
+ I $D(^XTMP(PXRMXTMP)),'$D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XTMP(PXRMXTMP,""PRZTSK"") does not exist."
+ I $D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XMTP(PXRMXTMP,""PRZTSK"") is null."
+ S TEXT(4,0)="PXRMXTMP="_PXRMXTMP
+ M ^TMP("PXRMXMZ",$J)=TEXT
+ D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ)
+ Q
+ ;
+XTMP(START) ;
+ N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME,SUB,STATUS,TEMP,TEMP1
+ K ^TMP($J,"PXRM CNBD")
+ S CCNT=0,MCNBD=$G(^PXRM(800,1,"MIERR")),MCNBDR=0
+ ;I PXRMDBUG="Y" D DEBUG("PATIENT DATA","P","^TMP($J,""PXRM PATIENT EVAL"")")
+ S BUSY=0,SUB="NAM",TEMP=0,PX="PXRM"
+ N DDAT,DDUE,DEMARR,DFN,DLAST,DNEXT,FACILITY,NAM,PNAM
+ S FACILITY="",DDAT="N/A"
+ F  S FACILITY=$O(^TMP(PXRMRT,$J,FACILITY)) Q:FACILITY=""  D
+ .S NAM=""
+ .F  S NAM=$O(^TMP(PXRMRT,$J,FACILITY,NAM)) Q:NAM=""  D
+ ..S DFN="" F  S DFN=$O(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) Q:DFN=""  D
+ ...I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Evaluating Reminders",.BUSY)
+ ...S INP=$G(^TMP(PXRMRT,$J,FACILITY,NAM,DFN))
+ ...S CNT=0 F  S CNT=$O(REMINDER(CNT)) Q:CNT'>0  D
+ ....S ITEM=$P(REMINDER(CNT),U,1),LIT=$P(REMINDER(CNT),U,4)
+ ....I LIT="" S LIT=$P(REMINDER(CNT),U,2)
+ ....S STATUS=$G(^TMP($J,"PXRM PATIENT EVAL",DFN,ITEM))
+ ....I STATUS="" Q
+ ....I STATUS["ERROR"!(STATUS["CNBD") D
+ .....D ERROR(STATUS,ITEM) I STATUS["ERROR"!(MCNBDR=1) Q
+ .....I CCNT=0 D  Q
+ ......S ^TMP($J,"PXRM CNBD",1,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR("PATIENT NAME",30)_$$RJ^XLFSTR("LAST 4",10)
+ ......S (TEMP,TEMP1)=""
+ ......F X=1:1:30 S TEMP=TEMP_"_"
+ ......F X=1:1:6 S TEMP1=TEMP1_"_"
+ ......S ^TMP($J,"PXRM CNBD",2,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(TEMP,30)_$$RJ^XLFSTR(TEMP1,10)
+ ......S CCNT=2
+ .....S CCNT=CCNT+1
+ .....I CCNT>MCNBD S MCNBDR=1 Q
+ .....S NAME=$P(^DPT(DFN,0),U)
+ .....S LSSN=$E($P(^DPT(DFN,0),U,9),6,9)
+ .....S ^TMP($J,"PXRM CNBD",CCNT,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(NAME,30)_$$RJ^XLFSTR(LSSN,10)
+ ....;Add reminder status to patient list TMP Global
+ ....I STATUS["DUE NOW" S ^TMP($J,"PXRMXPAT",DFN,"REM",ITEM)=ITEM_U_STATUS
+ ....I PXRMREP="D" D SDET^PXRMXDT1(DFN,STATUS,NAM,FACILITY,INP)
+ ....I PXRMREP="S" D SUM^PXRMXDT1(DFN,STATUS,FACILITY,NAM)
+ I $D(^TMP($J,"PXRM CNBD"))>0 D DBDOWN^PXRMXDT1("C")
+ K ^TMP($J,"PXRM CNBD")
+ S END=$H
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Evaluating Reminders")
+ ;I PXRMDBUG="Y" D DEBUG("DEBUG PATIENT DATA EVALUATION","DEBUG","^TMP($J,""PXRMDEBUG"")")
+ K ^TMP($J,"PXRM PATIENT EVAL")
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m

@@ -1 @@
-PXRMXSL1        ; SLC/PJH - Process Visits/Appts Reminder Due report;02/07/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-        ; Called from PXRMXSE
-        ;
-TMP(DFN,NAM,FACILITY,INP)       ;Update ^TMP("PXRMX"
-        I PXRMFCMB="Y" S FACILITY="COMBINED FACILITIES"
-        I PXRMLCMB="Y" S NAM="COMBINED LOCATIONS"
-        S ^TMP("PXRMX",$J,FACILITY,NAM,DFN)=INP
-        Q
-        ;
-        ;Mark location as found
-MARK(IC)        ;
-        S ^XTMP(PXRMXTMP,"MARKED AS FOUND",IC)=""
-        Q
-        ;
-        ;Check if facility is on list, PXMRFACN.
-HFAC(HLOCIEN)   ;
-        N DIV,HFAC
-        ;DBIA #2804
-        S HFAC=$P(^SC(HLOCIEN,0),U,4)
-        I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7)
-        I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3)
-        I HFAC="" Q ""
-        I '$D(PXRMFACN(HFAC)) Q ""
-        Q HFAC
-        ;
-INACTCL(HLIEN,PXRMBDT)  ;
-        ;Check to see if clinic is inactivated before the start of 
-        ;the reporting period
-        N INACT,REACT
-        S INACT=+$P($G(^SC(HLIEN,"I")),U) I INACT=0 Q 0
-        S REACT=+$P($G(^SC(HLIEN,"I")),U,2)
-        I REACT'<INACT Q 0
-        I INACT<PXRMBDT Q 1
-        Q 0
-        ;
-INPADM  ;
-        ;Build list of inpatients admissions and current patients on a ward
-        N BD,DFN,ED,FACILITY,HIEN,NAM
-        S NAM="All Locations"
-        S HIEN=0
-        F  S HIEN=$O(^XTMP(PXRMXTMP,"HLOC",HIEN)) Q:HIEN'>0  D
-        .S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,1)
-        .;Get WARDIEN,WARDNAM and return DFN's in PATS
-        .N PATS
-        .I PXRMFD="C" D WARD^PXRMXAP(HIEN,.PATS)
-        .I PXRMFD="A" D
-        ..; Get admissions from patient movements and return DFN's in PATS
-        ..S BD=PXRMBDT-.0001
-        ..S ED=PXRMEDT+.2359
-        ..D ADM^PXRMXAP(HIEN,.PATS,BD,ED)
-        .;Split report by location
-        .I PXRMLCMB="N" S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,2)
-        .;Build ^TMP for selected patients 
-        .S DFN="",FOUND=0
-        .F  S DFN=$O(PATS(DFN)) Q:DFN=""  D
-        ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
-        ..D TMP(DFN,NAM,FACILITY,HIEN) D MARK(HIEN)
-        Q
-        ;
-BHLOC   ;
-        N CLINIEN,END,FACILITY,NAM,HLIEN,I,START,TEXT
-        N INACT,REACT
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        ;All inpatient, outpatient all location credit stop and encounter
-        S START=$H
-        I $P(PXRMLCSC,U)["HA"!($P(PXRMLCSC,U)="CA") D
-        .S HLIEN=0 F  S HLIEN=$O(^SC(HLIEN)) Q:HLIEN'>0  D
-        ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
-        ..I $$INACTCL(HLIEN,PXRMBDT)=1 Q
-        ..S NAM=$P(^SC(HLIEN,0),U)
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
-        ..;All inpatient location
-        ..I $P(PXRMLCSC,U)="HAI",$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q
-        ..;All outpatient locations
-        ..I $P(PXRMLCSC,U)="HA",'$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q
-        ..;All encounters with a credit stop
-        ..I $P(PXRMLCSC,U)="CA",$P($G(^SC(HLIEN,0)),U,7)>0 S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q
-        ;Select hosiptal locations
-        I $P(PXRMLCSC,U,1)="HS" D
-        .S HLIEN=0 F  S HLIEN=$O(PXRMLOCN(HLIEN)) Q:HLIEN'>0  D
-        ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
-        ..I $$INACTCL(HLIEN,PXRMBDT)=1 Q
-        ..S NAM=$P(^SC(HLIEN,0),U)
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
-        ..S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM
-        ;Select Credit Stops
-        I PXRMSEL="L",$P(PXRMLCSC,U)="CS" D
-        .S CLINIEN=0 F  S CLINIEN=$O(PXRMCSN(CLINIEN)) Q:CLINIEN'>0  D
-        ..S HLIEN=0 F  S HLIEN=$O(^SC("AST",CLINIEN,HLIEN)) Q:HLIEN'>0  D
-        ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
-        ...I $$INACTCL(HLIEN,PXRMBDT)=1 Q
-        ...S NAM=$P(^DIC(40.7,CLINIEN,0),U)_" "_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3)
-        ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
-        ...S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM_U_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3)
-        ;Selected Clinic Groups
-        I PXRMSEL="L",$E(PXRMLCSC)="G" D
-        .S CGRPIEN=0 F  S CGRPIEN=$O(PXRMCGRN(CGRPIEN)) Q:CGRPIEN'>0  D
-        ..S HLIEN=0 F  S HLIEN=$O(^SC("ASCRPW",CGRPIEN,HLIEN)) Q:HLIEN'>0  D
-        ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
-        ...I $$INACTCL(HLIEN,PXRMBDT)=1 Q
-        ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
-        ...S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_$P(^SC(HLIEN,0),U)_U_CGRPIEN
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        S END=$H
-        S TEXT="Elapsed time for building hospital locations: "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","BUILDING HOSPITAL LOCATIONS")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        Q
-        ;
-DETIME(START,END)       ;
-        N ETIME,TEXT
-        S ETIME=$$HDIFF^XLFDT(END,START,2)
-        I ETIME>90 D
-        . S ETIME=$$HDIFF^XLFDT(END,START,3)
-        . S TEXT=ETIME
-        E  S TEXT=ETIME_" secs"
-        Q TEXT
-        ;
-OERR    ;
-        N CNT,II,NAM,OTM
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        S II=""
-        ;Get patient list for each team
-        F  S II=$O(PXRMOTM(II)) Q:II=""  D
-        .S OTM=$P(PXRMOTM(II),U),NAM=$P(PXRMOTM(II),U,2)
-        .;Build list of patients for OE/RR team ; DBIA #2692
-        .K ^TMP($J,"OTM")
-        .D TEAMPTS^ORQPTQ1("^TMP($J,""OTM"",",OTM,1)
-        .I $G(^TMP($J,"OTM",1))["No patients found" Q
-        .I PXRMTCMB="Y" N OTM,NAM S OTM="COMBINED",NAM="COMBINED TEAMS"
-        .S CNT=0 F  S CNT=$O(^TMP($J,"OTM",CNT)) Q:CNT'>0  D
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from OE/RR List",.BUSY)
-        ..S DFN=$P(^TMP($J,"OTM",CNT),U)
-        ..D UPD1(DFN,NAM,"FACILITY",II)
-        .D MARK(OTM)
-        K ^TMP($J,"OTM")
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
-        Q
-        ;
-        ;PCMM provider selected
-PCMMP   ;
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,PXRM,OK
-        N FACILITY,NAM
-        S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT
-        ;Include patient if in team on any day in range
-        S SCDT("INCL")=0
-        S II=""
-        ;Get patient list for each PROVIDER
-        F  S II=$O(PXRMPRV(II)) Q:II=""  D
-        .S PCM=$P(PXRMPRV(II),U),NAM=$P(PXRMPRV(II),U,2)
-        .;Get patients for practs. roles - excluding assoc clinics
-        .K ^TMP($J,"PCM")
-        .N SCTEAM D PTPR^PXRMXAP(PCM,PXRMREP)
-        .I $O(^TMP($J,"PCM",0))="" Q
-        .;Save in ^TMP in alpha order within team number (internal)
-        .S CNT=0 F  S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0  D
-        ..S DFN=$P(^TMP($J,"PCM",CNT),U)
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Primary Provider List",.BUSY)
-        ..I PXRMPRIM="P",($$PCASSIGN^PXRMXAP(DFN)'=1) Q
-        ..;For detailed provider report get assoc clinic
-        ..I PXRMREP="D" S DCLN=$P(^TMP($J,"PCM",CNT),U,7) I +$G(DCLN)>0 D
-        ...S FACILITY=$$HFAC(DCLN)
-        ...S NAM=$P(^SC(DCLN,0),U)
-        ...S ^XTMP(PXRMXTMP,"HLOC",DCLN)=FACILITY_U_NAM
-        ..I $G(DCLN)'="" S PXRMDCLN(DCLN)=""
-        ..D UPD1(DFN,NAM,"FACILITY",+$G(DCLN))
-        .D MARK(PCM)
-        K ^TMP($J,"PCM")
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
-        Q
-        ;
-        ;PCMM team selected
-PCMMT   ;
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,OK
-        S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT
-        ;Include patient if in team on any day in range
-        S SCDT("INCL")=0
-        S II=""
-        ;Get patient list for each team
-        F  S II=$O(PXRMPCM(II)) Q:II=""  D
-        .S PCM=$P(PXRMPCM(II),U),NAM=$P(PXRMPCM(II),U,2)
-        .K ^TMP($J,"PCM")
-        .S OK=$$PTTM^PXRMXAP(PCM,.SCERR) Q:'OK
-        .I $O(^TMP($J,"PCM",0))="" Q
-        .S FACILITY=$$FAC^PXRMXAP(PCM)
-        .S CNT=0 F  S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0  D
-        ..S DFN=$P(^TMP($J,"PCM",CNT),U)
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from PCMM Team List",.BUSY)
-        ..D UPD1(DFN,NAM,FACILITY,II)
-        .D MARK(PCM)
-        K ^TMP($J,"PCM")
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
-        Q
-        ;
-        ;Individual Patients selected
-IND     ;
-        N CNT,DFN,DUMMY,LIST,NAM
-        S (DUMMY,NAM)="PATIENT"
-        S CNT=0 F  S CNT=$O(PXRMPAT(CNT)) Q:CNT'>0  D
-        .S DFN=$P(PXRMPAT(CNT),U)
-        .D UPD1(DFN,"INDIVIDUAL PATIENTS","FACILITY",DFN)
-        I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
-        Q
-        ;
-        ;Patient lists selected
-LIST    ;
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        N DFN,DSUB,DUMMY,LCNT,LIEN,LIST,NAM
-        S (DUMMY,NAM)="PATIENT",LCNT=0
-        F  S LCNT=$O(PXRMLIST(LCNT)) Q:'LCNT  D
-        .S LIEN=$P(PXRMLIST(LCNT),U) Q:'LIEN
-        .S NAM=$P(^PXRMXP(810.5,LIEN,0),U)
-        .S DSUB=0
-        .F  S DSUB=$O(^PXRMXP(810.5,LIEN,30,DSUB)) Q:'DSUB  D
-        ..S DFN=$P($G(^PXRMXP(810.5,LIEN,30,DSUB,0)),U) Q:'DFN
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Reminder Patient List",.BUSY)
-        ..D UPD1(DFN,NAM,"FACILITY",LIEN)
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
-        Q
-        ;
-UPD1(DFN,NAM,FACILITY,INP)      ;
-        ;Remove test patients.
-        I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
-        ;Remove patients that are deceased.
-        I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
-        S ^TMP($J,"PXRM PATIENT LIST",DFN)=""
-        S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
-        D TMP(DFN,NAM,FACILITY,INP)
-        Q
-        ;
+PXRMXSL1 ; SLC/PJH - Process Visits/Appts Reminder Due report;12/09/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ; Called from PXRMXSE
+ ;
+TMP(DFN,NAM,FACILITY,INP) ;Update ^TMP("PXRMX"
+ I PXRMFCMB="Y" S FACILITY="COMBINED FACILITIES"
+ I PXRMLCMB="Y" S NAM="COMBINED LOCATIONS"
+ S ^TMP("PXRMX",$J,FACILITY,NAM,DFN)=INP
+ Q
+ ;
+ ;Mark location as found
+MARK(IC) ;
+ S ^XTMP(PXRMXTMP,"MARKED AS FOUND",IC)=""
+ Q
+ ;
+ ;Check if facility is on list, PXMRFACN.
+HFAC(HLOCIEN) ;
+ N DIV,HFAC
+ ;DBIA #2804
+ S HFAC=$P(^SC(HLOCIEN,0),U,4)
+ I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7)
+ I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3)
+ I HFAC="" Q ""
+ I '$D(PXRMFACN(HFAC)) Q ""
+ Q HFAC
+ ;
+INPADM ;
+ ;Build list of inpatients admissions and current patients on a ward
+ N BD,DFN,ED,FACILITY,HIEN,NAM
+ S NAM="All Locations"
+ S HIEN=0
+ F  S HIEN=$O(^XTMP(PXRMXTMP,"HLOC",HIEN)) Q:HIEN'>0  D
+ .S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,1)
+ .;Get WARDIEN,WARDNAM and return DFN's in PATS
+ .N PATS
+ .I PXRMFD="C" D WARD^PXRMXAP(HIEN,.PATS)
+ .I PXRMFD="A" D
+ ..; Get admissions from patient movements and return DFN's in PATS
+ ..S BD=PXRMBDT-.0001
+ ..S ED=PXRMEDT+.2359
+ ..D ADM^PXRMXAP(HIEN,.PATS,BD,ED)
+ .;Split report by location
+ .I PXRMLCMB="N" S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,2)
+ .;Build ^TMP for selected patients 
+ .S DFN="",FOUND=0
+ .F  S DFN=$O(PATS(DFN)) Q:DFN=""  D
+ ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
+ ..D TMP(DFN,NAM,FACILITY,HIEN) D MARK(HIEN)
+ Q
+ ;
+BHLOC ;
+ N CLINIEN,END,FACILITY,NAM,HLIEN,I,START
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ ;All inpatient, outpatient all location credit stop and encounter
+ S START=$H
+ I $P(PXRMLCSC,U)["HA"!($P(PXRMLCSC,U)="CA") D
+ .S HLIEN=0 F  S HLIEN=$O(^SC(HLIEN)) Q:HLIEN'>0  D
+ ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
+ ..S NAM=$P(^SC(HLIEN,0),U)
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
+ ..;All inpatient location
+ ..I $P(PXRMLCSC,U)="HAI",$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q
+ ..;All outpatient locations
+ ..I $P(PXRMLCSC,U)="HA",'$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q
+ ..;All encounters with a credit stop
+ ..I $P(PXRMLCSC,U)="CA",$P($G(^SC(HLIEN,0)),U,7)>0 S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q
+ ;Select hosiptal locations
+ I $P(PXRMLCSC,U,1)="HS" D
+ .S HLIEN=0 F  S HLIEN=$O(PXRMLOCN(HLIEN)) Q:HLIEN'>0  D
+ ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
+ ..S NAM=$P(^SC(HLIEN,0),U)
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
+ ..S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM
+ ;Select Credit Stops
+ I PXRMSEL="L",$P(PXRMLCSC,U)="CS" D
+ .S CLINIEN=0 F  S CLINIEN=$O(PXRMCSN(CLINIEN)) Q:CLINIEN'>0  D
+ ..S HLIEN=0 F  S HLIEN=$O(^SC("AST",CLINIEN,HLIEN)) Q:HLIEN'>0  D
+ ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
+ ...S NAM=$P(^DIC(40.7,CLINIEN,0),U)_" "_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3)
+ ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
+ ...S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM_U_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3)
+ ;Selected Clinic Groups
+ I PXRMSEL="L",$E(PXRMLCSC)="G" D
+ .S CGRPIEN=0 F  S CGRPIEN=$O(PXRMCGRN(CGRPIEN)) Q:CGRPIEN'>0  D
+ ..S HLIEN=0 F  S HLIEN=$O(^SC("ASCRPW",CGRPIEN,HLIEN)) Q:HLIEN'>0  D
+ ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
+ ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
+ ...S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_$P(^SC(HLIEN,0),U)_U_CGRPIEN
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ S END=$H
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME(START,END,"Building Hospital Locations")
+ Q
+ ;
+DETIME(START,END,SECTION) ;
+ N ETIME,TEXT
+ S ETIME=$$HDIFF^XLFDT(END,START,2)
+ I ETIME>90 D
+ . S ETIME=$$HDIFF^XLFDT(END,START,3)
+ . S TEXT="Elapsed time for "_SECTION_": "_ETIME
+ E  S TEXT="Elapsed time for "_SECTION_": "_ETIME_" secs"
+ D MES^XPDUTL(TEXT)
+ Q
+ ;
+OERR ;
+ N CNT,II,NAM,OTM
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ S II=""
+ ;Get patient list for each team
+ F  S II=$O(PXRMOTM(II)) Q:II=""  D
+ .S OTM=$P(PXRMOTM(II),U),NAM=$P(PXRMOTM(II),U,2)
+ .;Build list of patients for OE/RR team ; DBIA #2692
+ .K ^TMP($J,"OTM")
+ .D TEAMPTS^ORQPTQ1("^TMP($J,""OTM"",",OTM,1)
+ .I $G(^TMP($J,"OTM",1))["No patients found" Q
+ .I PXRMTCMB="Y" N OTM,NAM S OTM="COMBINED",NAM="COMBINED TEAMS"
+ .S CNT=0 F  S CNT=$O(^TMP($J,"OTM",CNT)) Q:CNT'>0  D
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from OE/RR List",.BUSY)
+ ..S DFN=$P(^TMP($J,"OTM",CNT),U)
+ ..D UPD1(DFN,NAM,"FACILITY",II)
+ .D MARK(OTM)
+ K ^TMP($J,"OTM")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
+ Q
+ ;
+ ;PCMM provider selected
+PCMMP ;
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,PXRM,OK
+ S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT
+ ;Include patient if in team on any day in range
+ S SCDT("INCL")=0
+ S II=""
+ ;Get patient list for each PROVIDER
+ F  S II=$O(PXRMPRV(II)) Q:II=""  D
+ .S PCM=$P(PXRMPRV(II),U),NAM=$P(PXRMPRV(II),U,2)
+ .;Get patients for practs. roles - excluding assoc clinics
+ .K ^TMP($J,"PCM")
+ .N SCTEAM D PTPR^PXRMXAP(PCM,PXRMREP)
+ .I $O(^TMP($J,"PCM",0))="" Q
+ .;Save in ^TMP in alpha order within team number (internal)
+ .S CNT=0 F  S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0  D
+ ..S DFN=$P(^TMP($J,"PCM",CNT),U)
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Primary Provider List",.BUSY)
+ ..I PXRMPRIM="P",($$PCASSIGN^PXRMXAP(DFN)'=1) Q
+ ..;For detailed provider report get assoc clinic
+ ..I PXRMREP="D" S DCLN=$P(^TMP($J,"PCM",CNT),U,7) I $G(DCLN)'="" S ^XTMP(PXRMXTMP,"HLOC",DCLN)=""
+ ..I $G(DCLN)'="" S PXRMDCLN(DCLN)=""
+ ..D UPD1(DFN,NAM,"FACILITY",+$G(DCLN))
+ .D MARK(PCM)
+ K ^TMP($J,"PCM")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
+ Q
+ ;
+ ;PCMM team selected
+PCMMT ;
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,OK
+ S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT
+ ;Include patient if in team on any day in range
+ S SCDT("INCL")=0
+ S II=""
+ ;Get patient list for each team
+ F  S II=$O(PXRMPCM(II)) Q:II=""  D
+ .S PCM=$P(PXRMPCM(II),U),NAM=$P(PXRMPCM(II),U,2)
+ .K ^TMP($J,"PCM")
+ .S OK=$$PTTM^PXRMXAP(PCM,.SCERR) Q:'OK
+ .I $O(^TMP($J,"PCM",0))="" Q
+ .S FACILITY=$$FAC^PXRMXAP(PCM)
+ .S CNT=0 F  S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0  D
+ ..S DFN=$P(^TMP($J,"PCM",CNT),U)
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from PCMM Team List",.BUSY)
+ ..D UPD1(DFN,NAM,FACILITY,II)
+ .D MARK(PCM)
+ K ^TMP($J,"PCM")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
+ Q
+ ;
+ ;Individual Patients selected
+IND ;
+ N CNT,DFN,DUMMY,LIST,NAM
+ S (DUMMY,NAM)="PATIENT"
+ S CNT=0 F  S CNT=$O(PXRMPAT(CNT)) Q:CNT'>0  D
+ .S DFN=$P(PXRMPAT(CNT),U)
+ .D UPD1(DFN,"INDIVIDUAL PATIENTS","FACILITY",DFN)
+ I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
+ Q
+ ;
+ ;Patient lists selected
+LIST ;
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ N DFN,DSUB,DUMMY,LCNT,LIEN,LIST,NAM
+ S (DUMMY,NAM)="PATIENT",LCNT=0
+ F  S LCNT=$O(PXRMLIST(LCNT)) Q:'LCNT  D
+ .S LIEN=$P(PXRMLIST(LCNT),U) Q:'LIEN
+ .S NAM=$P(^PXRMXP(810.5,LIEN,0),U)
+ .S DSUB=0
+ .F  S DSUB=$O(^PXRMXP(810.5,LIEN,30,DSUB)) Q:'DSUB  D
+ ..S DFN=$P($G(^PXRMXP(810.5,LIEN,30,DSUB,0)),U) Q:'DFN
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Reminder Patient List",.BUSY)
+ ..D UPD1(DFN,NAM,"FACILITY",LIEN)
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP)
+ Q
+ ;
+UPD1(DFN,NAM,FACILITY,INP) ;
+ ;Remove test patients.
+ I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
+ ;Remove patients that are deceased.
+ I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
+ S ^TMP($J,"PXRM PATIENT LIST",DFN)=""
+ S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
+ D TMP(DFN,NAM,FACILITY,INP)
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m

@@ -1 @@
-PXRMXSL2        ; SLC/AGP - Process Visits/Appts Reminder Due report; 08/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ;
-APPTS   ;
-        ;Call to SDAMA301 for future appointments
-        N APPTDT,BDT,EDT,NODE,DFN,FACILITY,HLIEN,NAM
-        S NAM="All Locations"
-        S BDT=PXRMBDT
-        ;I PXRMBDT["." S BDT=PXRMBDT
-        ;E  S BDT=PXRMBDT-.0001
-        I PXRMEDT["." S EDT=PXRMEDT
-        E  S EDT=PXRMEDT+.2359
-        D SDAM301(BDT,EDT,PXRMSEL,PXRMFD,PXRMREP)
-        I DBDOWN=1 Q
-        S DFN=0 F  S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0!(ZTSTOP=1)  D
-        .;Remove test patients.
-        .I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
-        .;Remove patients that are deceased.
-        .I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
-        .S APPTDT=0 F  S APPTDT=$O(^TMP($J,"SDAMA301",DFN,APPTDT)) Q:APPTDT'>0!(ZTSTOP=1)  D
-        ..S NODE=$G(^TMP($J,"SDAMA301",DFN,APPTDT))
-        ..S HLIEN=$P($P(NODE,U,2),";")
-        ..S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,1)
-        ..S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,2)
-        ..I PXRMREP="D" D
-        ...S ^TMP($J,"PXRM FUTURE APPT",DFN,HLIEN,APPTDT)=NODE
-        ...S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,APPTDT)=NODE
-        ..I $$S^%ZTLOAD S ZTSTOP=1 Q
-        ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN),MARK^PXRMXSL1(HLIEN)
-        ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
-        K ^TMP($J,"SDAMA301")
-        Q
-        ;
-GETHFAC(HLOCIEN)        ;
-        N DIV,HFAC
-        ;DBIA #2804
-        S HFAC=$P(^SC(HLOCIEN,0),U,4)
-        I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7)
-        I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3)
-        Q +HFAC
-        ;
-SDAM301(BD,ED,PXRMSEL,PXRMFD,PXRMREP)   ;
-        N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS,TEXT
-        K ^TMP($J,"PXRM FUTURE APPT")
-        K ^TMP($J,"PXRM FACILITY FUTURE APPT")
-        ;
-        I ED'>0 S ARRAY(1)=BD
-        I ED>0 S ARRAY(1)=BD_";"_ED
-        I PXRMREP="D",PXRMSEL="L",PXRMFD="P" S ARRAY(1)=BD
-        ;
-        I $D(^XTMP(PXRMXTMP,"HLOC"))>0 S ARRAY(2)="^XTMP(PXRMXTMP,""HLOC"","
-        ;S ARRAY(3)=$S(PXRMFD="P":"R;I;NS;NSR;CP;CPR;CC;CCR;NT",1:"R;I")
-        S ARRAY(3)=$S(PXRMFD="P":"R;I",1:"R;I;NT")
-        I $D(^TMP($J,"PXRM PATIENT LIST"))>0 S ARRAY(4)="^TMP($J,""PXRM PATIENT LIST"""
-        S ARRAY("FLDS")="1;2;3;10;12;13;14;22"
-        I $D(^TMP($J,"PXRM PATIENT LIST"))=0 S ARRAY("SORT")="P"
-        ;
-        N END,START,BUSY
-        S START=$H
-        S BUSY=0
-        ;DBIA #4433
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y"))) D SPIN^PXRMXBSY("Calling the scheduling package to gather appointment data",.BUSY)
-        S COUNT=$$SDAPI^SDAMA301(.ARRAY)
-        S END=$H
-        S TEXT="Elapsed time for call to the Scheduling Package: "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","SCHEDULING")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        I COUNT<0 D  Q
-        .N CNT
-        .S DBDOWN=1,CNT=0
-        .F  S CNT=$O(^TMP($J,"SDAMA301",CNT)) Q:CNT'>0  D
-        ..S DBERR(CNT)=$G(^TMP($J,"SDAMA301",CNT))
-        .D ERRMSG^PXRMXDT1("E")
-        ;
-LOOP    ;
-        I PXRMFD'="P"!(PXRMSEL'="L") Q
-        N APPTDT,CIEN,DFN,FUTDT,NODE,TEXT,VIEN
-        ;LOOP THROUGH PATIENT
-        S START=$H
-        S BUSY=0
-        S FUTDT=$S(DT>$P(ED,"."):DT,1:$P(ED,"."))
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Sorting SDAMA301 Output",.BUSY)
-        S DFN=0 F  S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0  D
-        .;
-        .;LOOP THROUGH CLINICS
-        .S CIEN=0
-        .F  S CIEN=$O(^TMP($J,"SDAMA301",DFN,CIEN)) Q:CIEN'>0  D
-        ..S APPTDT=0
-        ..F  S APPTDT=$O(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT)) Q:APPTDT'>0  D
-        ...I PXRMREP="S",$P(APPTDT,".")>$P(ED,".") Q
-        ...S NODE=$G(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT))
-        ...;S STATUS=$P($P(NODE,U,3),";")
-        ...;I ($P(ED,".")+1)>($P(APPTDT,".")),STATUS'="I",STATUS'="R",STATUS'="NT" D
-        ...;.K ^TMP($J,"PXRM PATIENT LIST",DFN,CIEN,APPTDT)
-        ...;
-        ...;if report is detailed report store future appointment
-        ...I $P(APPTDT,".")>FUTDT D
-        ....S ^TMP($J,"PXRM FUTURE APPT",DFN,CIEN,APPTDT)=NODE
-        ....S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,$$GETHFAC(CIEN),APPTDT)=NODE
-        K ^TMP($J,"SDAMA301")
-        S END=$H
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        S TEXT="Elapsed time for sorting SDAMA301 output: "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","SCHEDULE SORT")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        Q
-        ;
-        ;Scan visit file to build list of patients
-VISITS  ;
-        N BUSY,DAS,DATE,DFN,DS,END,ETIME,HLOC,NF
-        N SC,START,TEMP,TEXT,TGLIST,TIME
-        S START=$H
-        K ^TMP($J,"PXRM PATIENT LIST")
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        W !,"Building patient list "
-        K ^TMP($J,"HLOCL"),^TMP($J,"PLIST")
-        M ^TMP($J,"HLOCL")=^XTMP(PXRMXTMP,"HLOC")
-        D FPLIST^PXRMLOCL(9000010,"HLOCL",-1,PXRMBDT,PXRMEDT,"PLIST")
-        K ^TMP($J,"HLOCL")
-        S DFN=""
-        F  S DFN=$O(^TMP($J,"PLIST",DFN)) Q:DFN=""  D
-        . S NF=0
-        . F  S NF=$O(^TMP($J,"PLIST",DFN,NF)) Q:NF=""  D
-        .. S TEMP=^TMP($J,"PLIST",DFN,NF)
-        .. S SC=$P(TEMP,U,4)
-        .. I '$D(PXRMSCAT(SC)) Q
-        .. ;Remove test Patients
-        .. I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
-        .. ;Remove deceased patients
-        .. I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
-        .. S DAS=$P(TEMP,U,1),DATE=$P(TEMP,U,2),HLOC=$P(TEMP,U,3)
-        .. S ^TMP($J,"PXRM PATIENT LIST",DFN,HLOC,DATE,DAS)=""
-        K ^TMP($J,"PLIST")
-        S END=$H
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        S TEXT="Elapsed time for building patient list: "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","PATIENT LIST")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        I PXRMREP="D" D SDAM301(PXRMBDT,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
-        I DBDOWN=1 Q
-        S START=$H
-        S BUSY=0
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        N HLIEN,NAM,FACILITY,LSEL,NODE
-        S DFN=0 F  S DFN=$O(^TMP($J,"PXRM PATIENT LIST",DFN)) Q:DFN'>0  D
-        .S HLIEN=0
-        .F  S HLIEN=$O(^TMP($J,"PXRM PATIENT LIST",DFN,HLIEN)) Q:HLIEN'>0  D
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Removing Invalid Encounter(s)",.BUSY)
-        ..S NODE=$G(^XTMP(PXRMXTMP,"HLOC",HLIEN))
-        ..S FACILITY=$P(NODE,U),NAM=$P(NODE,U,2)
-        ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN)
-        ..S TEMP=$P(PXRMLCSC,U,1)
-        ..S LSEL=$S(TEMP="CS":$P(NODE,U,3),TEMP="GS":$P(NODE,U,3),1:HLIEN)
-        ..D MARK^PXRMXSL1(LSEL)
-        ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
-        S END=$H
-        S TEXT="Elapsed time for removing invalid encounter(s): "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","REMOVING INVALID ENCOUNTER(S)")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        Q
-        ;
-VISITSO ; Old entry point
-        N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
-        N NFOUND,SC,TEMP,TEXT,TGLIST,TIME
-        N DOD,START,END
-        S START=$H
-        K ^TMP($J,"PXRM PATIENT LIST")
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        S DEND=$S(PXRMEDT[".":PXRMEDT,1:PXRMEDT+.240001)
-        ;"AHL" in Visit file is inverse date_.time instead of a full inverse
-        ;date and time. For example if the date/time is 3030704.104449 then
-        ;"AHL" has 6969295.104449 instead of 6969295.89555
-        S INVBD=9999999-$P(PXRMBDT,".",1),BTIME=+("."_$P(PXRMBDT,".",2))
-        S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2))
-        S DS=INVED-.000001
-        S HLOC=""
-        F  S HLOC=$O(^XTMP(PXRMXTMP,"HLOC",HLOC)) Q:HLOC=""  D
-        . S INVDT=DS,DONE=0
-        . F  S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="")  D
-        ..I $$S^%ZTLOAD S ZTSTOP=1 Q
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Patient List",.BUSY)
-        .. S INVDATE=$P(INVDT,".",1)
-        .. I INVDATE>INVBD S DONE=1 Q
-        .. S TIME=+("."_$P(INVDT,".",2))
-        .. I INVDATE=INVED,TIME>ETIME Q
-        .. I INVDATE=INVBD,BTIME>TIME S DONE=1 Q
-        .. S DAS=0
-        .. F  S DAS=$O(^AUPNVSIT("AHL",HLOC,INVDT,DAS)) Q:DAS=""  D
-        ... S TEMP=^AUPNVSIT(DAS,0)
-        ... I $$VAPSTAT^PXRMVSIT(DAS)=0 Q
-        ... S SC=$P(TEMP,U,7)
-        ... I SC="" Q
-        ... I '$D(PXRMSCAT(SC)) Q
-        ... S DFN=$P(TEMP,U,5)
-        ... ;Remove Test Patients
-        ... I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
-        ... ;Remove Patient that are deceased
-        ... I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
-        ... S DATE=$P(TEMP,U,1)
-        ... S ^TMP($J,"PXRM PATIENT LIST",DFN,HLOC,DATE,DAS)=""
-        S END=$H
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        S TEXT="Elapsed time for building patient list: "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","PATIENT LIST")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        I PXRMREP="D" D SDAM301(PXRMBDT,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
-        ;D SDAM301(PXRMBDT-.0001,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
-        ;
-        I DBDOWN=1 Q
-        S START=$H
-        S BUSY=0
-        N NODE
-        I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
-        N DFN,HLIEN,NAM,FACILITY,LSEL,TEMP
-        S DFN=0 F  S DFN=$O(^TMP($J,"PXRM PATIENT LIST",DFN)) Q:DFN'>0  D
-        .S HLIEN=0
-        .F  S HLIEN=$O(^TMP($J,"PXRM PATIENT LIST",DFN,HLIEN)) Q:HLIEN'>0  D
-        ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Removing Invalid Encounter(s)",.BUSY)
-        ..S NODE=$G(^XTMP(PXRMXTMP,"HLOC",HLIEN))
-        ..S FACILITY=$P(NODE,U),NAM=$P(NODE,U,2)
-        ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN)
-        ..S TEMP=$P(PXRMLCSC,U,1)
-        ..S LSEL=$S(TEMP="CS":$P(NODE,U,3),TEMP="GS":$P(NODE,U,3),1:HLIEN)
-        ..D MARK^PXRMXSL1(LSEL)
-        ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
-        S END=$H
-        S TEXT="Elapsed time for removing invalid encounter(s): "_$$DETIME^PXRMXSL1(START,END)
-        S ^XTMP(PXRMXTMP,"TIMING","REMOVING INVALID ENCOUNTER(S)")=TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
-        I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
-        Q
+PXRMXSL2 ; SLC/AGP - Process Visits/Appts Reminder Due report; 06/07/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+APPTS ;
+ ;Call to SDAMA301 for future appointments
+ N APPTDT,BDT,EDT,NODE,DFN,FACILITY,HLIEN,NAM
+ S NAM="All Locations"
+ I PXRMBDT["." S BDT=PXRMBDT
+ E  S BDT=PXRMBDT-.0001
+ I PXRMEDT["." S EDT=PXRMEDT
+ E  S EDT=PXRMEDT+.2359
+ D SDAM301(BDT,EDT,PXRMSEL,PXRMFD,PXRMREP)
+ I DBDOWN=1 Q
+ S DFN=0 F  S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0!(ZTSTOP=1)  D
+ .;Remove test patients.
+ .I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
+ .;Remove patients that are deceased.
+ .I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
+ .S APPTDT=0 F  S APPTDT=$O(^TMP($J,"SDAMA301",DFN,APPTDT)) Q:APPTDT'>0!(ZTSTOP=1)  D
+ ..S NODE=$G(^TMP($J,"SDAMA301",DFN,APPTDT))
+ ..S HLIEN=$P($P(NODE,U,2),";")
+ ..S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,1)
+ ..S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,2)
+ ..I PXRMREP="D" D
+ ...S ^TMP($J,"PXRM FUTURE APPT",DFN,HLIEN,APPTDT)=NODE
+ ...S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,APPTDT)=NODE
+ ..I $$S^%ZTLOAD S ZTSTOP=1 Q
+ ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN),MARK^PXRMXSL1(HLIEN)
+ ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
+ K ^TMP($J,"SDAMA301")
+ Q
+ ;
+GETHFAC(HLOCIEN) ;
+ N DIV,HFAC
+ ;DBIA #2804
+ S HFAC=$P(^SC(HLOCIEN,0),U,4)
+ I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7)
+ I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3)
+ Q +HFAC
+ ;
+SDAM301(BD,ED,PXRMSEL,PXRMFD,PXRMREP) ;
+ N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS
+ K ^TMP($J,"PXRM FUTURE APPT")
+ K ^TMP($J,"PXRM FACILITY FUTURE APPT")
+ ;
+ I ED'>0 S ARRAY(1)=BD
+ I ED>0 S ARRAY(1)=BD_";"_ED
+ I PXRMREP="D",PXRMSEL="L",PXRMFD="P" S ARRAY(1)=BD
+ ;
+ I $D(^XTMP(PXRMXTMP,"HLOC"))>0 S ARRAY(2)="^XTMP(PXRMXTMP,""HLOC"","
+ ;S ARRAY(3)=$S(PXRMFD="P":"R;I;NS;NSR;CP;CPR;CC;CCR;NT",1:"R;I")
+ S ARRAY(3)=$S(PXRMFD="P":"R;I",1:"R;I;NT")
+ I $D(^TMP($J,"PXRM PATIENT LIST"))>0 S ARRAY(4)="^TMP($J,""PXRM PATIENT LIST"""
+ S ARRAY("FLDS")="1;2;3;10;12;13;14;22"
+ I $D(^TMP($J,"PXRM PATIENT LIST"))=0 S ARRAY("SORT")="P"
+ ;
+ N END,START,BUSY
+ S START=$H
+ S BUSY=0
+ ;DBIA #4433
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y"))) D SPIN^PXRMXBSY("Calling the scheduling package to gather appointment data",.BUSY)
+ S COUNT=$$SDAPI^SDAMA301(.ARRAY)
+ S END=$H
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Total amount of time to call the Scheduling Package")
+ I COUNT<0 D  Q
+ .N CNT
+ .S DBDOWN=1,CNT=0
+ .F  S CNT=$O(^TMP($J,"SDAMA301",CNT)) Q:CNT'>0  D
+ ..S DBERR(CNT)=$G(^TMP($J,"SDAMA301",CNT))
+ .D DBDOWN^PXRMXDT1("E")
+ ;
+LOOP ;
+ I PXRMFD'="P"!(PXRMSEL'="L") Q
+ N APPTDT,CIEN,DFN,FUTDT,NODE,VIEN
+ ;LOOP THROUGH PATIENT
+ S START=$H
+ S BUSY=0
+ S FUTDT=$S(DT>$P(ED,"."):DT,1:$P(ED,"."))
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Sorting SDAMA301 Output",.BUSY)
+ S DFN=0 F  S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0  D
+ .;
+ .;LOOP THROUGH CLINICS
+ .S CIEN=0
+ .F  S CIEN=$O(^TMP($J,"SDAMA301",DFN,CIEN)) Q:CIEN'>0  D
+ ..S APPTDT=0
+ ..F  S APPTDT=$O(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT)) Q:APPTDT'>0  D
+ ...I PXRMREP="S",$P(APPTDT,".")>$P(ED,".") Q
+ ...S NODE=$G(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT))
+ ...;S STATUS=$P($P(NODE,U,3),";")
+ ...;I ($P(ED,".")+1)>($P(APPTDT,".")),STATUS'="I",STATUS'="R",STATUS'="NT" D
+ ...;.K ^TMP($J,"PXRM PATIENT LIST",DFN,CIEN,APPTDT)
+ ...;
+ ...;if report is detailed report store future appointment
+ ...I $P(APPTDT,".")>FUTDT D
+ ....S ^TMP($J,"PXRM FUTURE APPT",DFN,CIEN,APPTDT)=NODE
+ ....S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,$$GETHFAC(CIEN),APPTDT)=NODE
+ K ^TMP($J,"SDAMA301")
+ S END=$H
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Sorting SDAMA301 Output")
+ Q
+ ;
+ ;Scan visit file to build list of patients
+VISITS ;
+ N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
+ N NFOUND,SC,TEMP,TGLIST,TIME
+ N DOD,START,END
+ S START=$H
+ K ^TMP($J,"PXRM PATIENT LIST")
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ S DEND=$S(PXRMEDT[".":PXRMEDT,1:PXRMEDT+.240001)
+ ;"AHL" in Visit file is inverse date_.time instead of a full inverse
+ ;date and time. For example if the date/time is 3030704.104449 then
+ ;"AHL" has 6969295.104449 instead of 6969295.89555
+ S INVBD=9999999-$P(PXRMBDT,".",1),BTIME=+("."_$P(PXRMBDT,".",2))
+ S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2))
+ S DS=INVED-1
+ S HLOC=""
+ F  S HLOC=$O(^XTMP(PXRMXTMP,"HLOC",HLOC)) Q:HLOC=""  D
+ . S INVDT=DS,DONE=0
+ . F  S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="")  D
+ ..I $$S^%ZTLOAD S ZTSTOP=1 Q
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Patient List",.BUSY)
+ .. S INVDATE=$P(INVDT,".",1)
+ .. I INVDATE>INVBD S DONE=1 Q
+ .. S TIME=+("."_$P(INVDT,".",2))
+ .. I INVDATE=INVED,TIME>ETIME Q
+ .. I INVDATE=INVBD,BTIME>TIME S DONE=1 Q
+ .. S DAS=0
+ .. F  S DAS=$O(^AUPNVSIT("AHL",HLOC,INVDT,DAS)) Q:DAS=""  D
+ ... S TEMP=^AUPNVSIT(DAS,0)
+ ... I $$VAPSTAT^PXRMVSIT(DAS)=0 Q
+ ... S SC=$P(TEMP,U,7)
+ ... I SC="" Q
+ ... I '$D(PXRMSCAT(SC)) Q
+ ... S DFN=$P(TEMP,U,5)
+ ... ;Remove Test Patients
+ ... I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
+ ... ;Remove Patient that are deceased
+ ... I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
+ ... S DATE=$P(TEMP,U,1)
+ ... S ^TMP($J,"PXRM PATIENT LIST",DFN,HLOC,DATE,DAS)=""
+ S END=$H
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Building Patient List")
+ D SDAM301(PXRMBDT-.0001,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
+ ;
+ I DBDOWN=1 Q
+ S START=$H
+ S BUSY=0
+ I DBDOWN=1 Q
+ N NODE
+ I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
+ N DFN,HLIEN,NAM,FACILITY,LSEL,TEMP
+ S DFN=0 F  S DFN=$O(^TMP($J,"PXRM PATIENT LIST",DFN)) Q:DFN'>0  D
+ .S HLIEN=0
+ .F  S HLIEN=$O(^TMP($J,"PXRM PATIENT LIST",DFN,HLIEN)) Q:HLIEN'>0  D
+ ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Removing Invalid Encounter(s)",.BUSY)
+ ..S NODE=$G(^XTMP(PXRMXTMP,"HLOC",HLIEN))
+ ..S FACILITY=$P(NODE,U),NAM=$P(NODE,U,2)
+ ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN)
+ ..S TEMP=$P(PXRMLCSC,U,1)
+ ..S LSEL=$S(TEMP="CS":$P(NODE,U,3),TEMP="GS":$P(NODE,U,3),1:HLIEN)
+ ..D MARK^PXRMXSL1(LSEL)
+ ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
+ S END=$H
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Removing Invalid Encounter(s)")
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m

@@ -1 @@
-PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;11/27/2006
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRMXD
-        ;
-        ;Select Template
-        ;---------------
-START   N X,Y,CNT,FOUND,PXRMFLD,DIC,MSG
-        N ERR,SEQ,TMPLST,LIST
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S PXRMTMP="",FOUND=0
-        ;
-        ;Check if any templates exist for the user
-        D GETLST^XPAR(.TMPLST,"USR","PXRM REPORT TEMPLATE (USER)","Q",.ERR)
-        I ERR>0 W !!,?5,"Error: "_$P(ERR,U,2) S DUOUT=1 H 2 Q
-        I 'TMPLST W !!,?5,"No report Templates for this user" S DUOUT=1 H 2 Q
-        ;Build list of templates
-        S SEQ=0
-        F  S SEQ=$O(TMPLST(SEQ)) Q:'SEQ  D
-        .S Y=$P(TMPLST(SEQ),U,2) Q:'Y
-        .S LIST(Y)=""
-        ;
-        ;Select template required
-        W !
-        S CNT=0,DIC=810.1,DIC(0)="AEQMZ"
-        S DIC("A")="Select REPORT TEMPLATE:"
-        S DIC("S")="I $D(LIST(+Y)),$P(^PXRMPT(810.1,+Y,0),U,3)=PXRMTYP"
-        D ^DIC
-        W !!,"1"
-        I X="" S DUOUT=1
-        I X=(U_U) S DTOUT=1
-        I '$D(DTOUT),('$D(DUOUT)) D
-        .I +Y'=-1 D  Q
-        ..S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
-        K DIC
-        ;
-        ;Load template into local array
-        I (+Y'=-1)&('$D(DTOUT))&('$D(DUOUT)) D
-        .L +^PXRMPT(810.1,$P(Y,U)):0
-        .E  W !!?5,"Another user is editing this entry." S DUOUT=1 Q
-        .;Load template into an array
-        .S PXRMTMP=Y_U_$P(Y(0),U,2) D LOAD^PXRMXT
-        .L -^PXRMPT(810.1,$P(PXRMTMP,U))
-        .;Exit if problem loading template
-        .I $D(MSG) S DTOUT=1 Q
-        .;Display Template information
-        .D:'$D(MSG) ^PXRMXTD
-EXIT    Q
-        ;
-XREF    ;       
-        K MREF,XREF
-        S XREF("NAME")=.01
-        S XREF("TITLE")=1.9
-        S XREF("PXRMTYP")=1.1
-        S XREF("PXRMSEL")=1.2
-        S XREF("PXRMPRIM")=1.3
-        S XREF("PXRMREP")=1.4
-        S XREF("PXRMLCSC")=1.5
-        S XREF("PXRMFD")=1.6
-        S XREF("PXRMPML")=1.7
-        S XREF("PXRMREM")=2
-        S XREF("PXRMFAC")=3
-        S XREF("PXRMPRV")=4
-        S XREF("RUN")=5
-        S XREF("PXRMPAT")=6
-        S XREF("PXRMOTM")=7
-        S XREF("PXRMPCM")=8
-        S XREF("PXRMSCAT")=9
-        S XREF("PXRMLCHL")=10
-        S XREF("PXRMCS")=11
-        S XREF("PXRMCGRP")=12
-        S XREF("PXRMRCAT")=13
-        S XREF("PXRMLIST")=14
-        ;
-        S MREF("REMINDER")=.01
-        S MREF("PATIENT")=.01
-        S MREF("PROVIDER")=.01
-        S MREF("OERR TEAM")=.01
-        S MREF("PCMM TEAM")=.01
-        S MREF("FACILITY")=.01
-        S MREF("SERVICE")=.01
-        S MREF("LOCATION")=.01
-        S MREF("STOP CODE")=.01
-        S MREF("CLINIC GROUP")=.01
-        S MREF("DISPLAY ORDER")=.02
-        S MREF("REMINDER CATEGORY")=.01
-        S MREF("DISPLAY")=.02
-        S MREF("PXRMLIST")=.01
-        Q
+PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;08/01/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ; 
+ ; Called from PXRMXD
+ ;
+ ;Select Template
+ ;---------------
+START N X,Y,CNT,FOUND,PXRMFLD,DIC,MSG
+ N ERR,SEQ,TMPLST,LIST
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S PXRMTMP="",FOUND=0
+ ;
+ ;Check if any templates exist for the user
+ D GETLST^XPAR(.TMPLST,"USR","PXRM REPORT TEMPLATE (USER)","Q",.ERR)
+ I ERR>0 W !!,?5,"Error: "_$P(ERR,U,2) S DUOUT=1 H 2 Q
+ I 'TMPLST W !!,?5,"No report Templates for this user" S DUOUT=1 H 2 Q
+ ;Build list of templates
+ S SEQ=0
+ F  S SEQ=$O(TMPLST(SEQ)) Q:'SEQ  D
+ .S Y=$P(TMPLST(SEQ),U,2) Q:'Y
+ .S LIST(Y)=""
+ ;
+ ;Select template required
+ W !
+ S CNT=0,DIC=810.1,DIC(0)="AEQMZ"
+ S DIC("A")="Select REPORT TEMPLATE:"
+ S DIC("S")="I $D(LIST(+Y)),$P(^PXRMPT(810.1,+Y,0),U,3)=PXRMTYP"
+ D ^DIC
+ W !!,"1"
+ I X="" S DUOUT=1
+ I X=(U_U) S DTOUT=1
+ I '$D(DTOUT),('$D(DUOUT)) D
+ .I +Y'=-1 D  Q
+ ..S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
+ K DIC
+ ;
+ ;Load template into local array
+ I (+Y'=-1)&('$D(DTOUT))&('$D(DUOUT)) D
+ .L +^PXRMPT(810.1,$P(Y,U)):0
+ .E  W !!?5,"Another user is editing this entry." S DUOUT=1 Q
+ .;Load template into an array
+ .S PXRMTMP=Y_U_$P(Y(0),U,2) D LOAD^PXRMXT
+ .L -^PXRMPT(810.1,$P(PXRMTMP,U))
+ .;Exit if problem loading template
+ .I $D(MSG) S DTOUT=1 Q
+ .;Display Template information
+ .D:'$D(MSG) ^PXRMXTD
+EXIT Q
+ ;
+XREF ;       
+ K MREF,XREF
+ S XREF("NAME")=.01
+ S XREF("TITLE")=1.9
+ S XREF("PXRMTYP")=1.1
+ S XREF("PXRMSEL")=1.2
+ S XREF("PXRMPRIM")=1.3
+ S XREF("PXRMREP")=1.4
+ S XREF("PXRMLCSC")=1.5
+ S XREF("PXRMFD")=1.6
+ S XREF("PXRMREM")=2
+ S XREF("PXRMFAC")=3
+ S XREF("PXRMPRV")=4
+ S XREF("RUN")=5
+ S XREF("PXRMPAT")=6
+ S XREF("PXRMOTM")=7
+ S XREF("PXRMPCM")=8
+ S XREF("PXRMSCAT")=9
+ S XREF("PXRMLCHL")=10
+ S XREF("PXRMCS")=11
+ S XREF("PXRMCGRP")=12
+ S XREF("PXRMRCAT")=13
+ S XREF("PXRMLIST")=14
+ ;
+ S MREF("REMINDER")=.01
+ S MREF("PATIENT")=.01
+ S MREF("PROVIDER")=.01
+ S MREF("OERR TEAM")=.01
+ S MREF("PCMM TEAM")=.01
+ S MREF("FACILITY")=.01
+ S MREF("SERVICE")=.01
+ S MREF("LOCATION")=.01
+ S MREF("STOP CODE")=.01
+ S MREF("CLINIC GROUP")=.01
+ S MREF("DISPLAY ORDER")=.02
+ S MREF("REMINDER CATEGORY")=.01
+ S MREF("DISPLAY")=.02
+ S MREF("PXRMLIST")=.01
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m

@@ -1 @@
-PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/16/2007
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRMXT/PXRMXTF
-        ;
-        ;
-        ;Display Template information
-START   ;----------------------------
-        N PAGE,BMARG,DONE,SD,ED,DES,RDES,CDES,PSTART,PXRMOPT,IC,CNT
-        S PAGE=1,BMARG=0,DONE=0,SD="",ED="",PSTART=10,CNT=0
-        ;
-        D LITS^PXRMXPR1
-        ;
-        I PXRMREP="D" S PXRMOPT="Detailed Report"
-        I PXRMREP="S" S PXRMOPT="Summary Report"
-        W !!?(PSTART),"Report Title:",?32,$P(PXRMTMP,U,3)
-        W !?PSTART,"Report Type:",?32,$G(PXRMOPT)
-        W !?PSTART,"Patient Sample:",?32,PXRMFLD
-        I "LT"[PXRMSEL D
-        .W !,?PSTART,"Facility:" D FAC
-        I PXRMSEL'="L" W !,?PSTART,PXRMFLD,":" D ARRS
-        I PXRMSEL="L" D
-        .W !?PSTART,PXRMFLD,":",?32,DES
-        .I $E(PXRMLCSC,2)'="A" W ! D ARRS
-        I DONE Q
-        W !?PSTART,"Print Locations without Patients:",?32,$S($G(PXRMPML)=0:"NO",1:"YES")
-        S IC="" F  S IC=$O(PXRMRCAT(IC)) Q:IC=""  D  Q:DONE
-        .W !,?PSTART W:IC=1 "Category:"
-        .W ?32,$P(PXRMRCAT(IC),U,3),?35,$P(PXRMRCAT(IC),U,2) D CHECK(1)
-        I DONE Q
-        S IC="" F  S IC=$O(PXRMREM(IC)) Q:IC=""  D  Q:DONE
-        .W !,?PSTART W:IC=1 "Reminder:"
-        .W ?32,$P(PXRMREM(IC),U,3),?35,$P(PXRMREM(IC),U,2) D CHECK(1)
-        I DONE Q
-        I PXRMSEL="P" W !,?PSTART,"All/Primary:",?32,CDES
-        W !?(PSTART),"Template Name:",?32,$P(PXRMTMP,U,2)
-        W !?PSTART,"Date last run:",?32,$S(RUN]"":RUN,1:"n/a")
-        I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART)
-EXIT    Q
-        ;
-        ;Display selected teams/providers
-        ;--------------------------------
-ARRS    N IC
-        S IC=""
-        I PXRMSEL="P" F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D  Q:DONE
-        .W:IC>1 ! W ?32,$P(PXRMPRV(IC),U,2) D CHECK(1)
-        I PXRMSEL="T" F  S IC=$O(PXRMPCM(IC)) Q:IC=""  D  Q:DONE
-        .W:IC>1 ! W ?32,$P(PXRMPCM(IC),U,2) D CHECK(1)
-        I PXRMSEL="O" F  S IC=$O(PXRMOTM(IC)) Q:IC=""  D  Q:DONE
-        .W:IC>1 ! W ?32,$P(PXRMOTM(IC),U,2) D CHECK(1)
-        I PXRMSEL="I" F  S IC=$O(PXRMPAT(IC)) Q:IC=""  D  Q:DONE
-        .W:IC>1 ! W ?32,$P(PXRMPAT(IC),U,2) D CHECK(1)
-        I PXRMSEL="R" F  S IC=$O(PXRMLIST(IC)) Q:IC=""  D  Q:DONE
-        .W:IC>1 ! W ?32,$P(PXRMLIST(IC),U,2) D CHECK(1)
-        I PXRMSEL="L" D
-        .I $E(PXRMLCSC)="H" F  S IC=$O(PXRMLCHL(IC)) Q:IC=""  D
-        ..W:IC>1 ! W ?32,$P(PXRMLCHL(IC),U) D CHECK(1)
-        .I $E(PXRMLCSC)="C" F  S IC=$O(PXRMCS(IC)) Q:IC=""  D
-        ..W:IC>1 ! W ?32,$P(PXRMCS(IC),U)," ",$P(PXRMCS(IC),U,3)
-        ..D CHECK(1)
-        .I $E(PXRMLCSC)="G" F  S IC=$O(PXRMCGRP(IC)) Q:IC=""  D
-        ..W:IC>1 ! W ?32,$P(PXRMCGRP(IC),U)," ",$P(PXRMCGRP(IC),U,2)
-        ..D CHECK(1)
-        Q
-        ;
-        ;Display selected Facilities
-        ;---------------------------
-FAC     N IC
-        S IC=""
-        F  S IC=$O(PXRMFAC(IC)) Q:IC=""  D  Q:DONE
-        .W:IC>1 ! W ?32,$P(PXRMFAC(IC),U,2) D CHECK(1)
-        Q
-        ;
-        ;
-        ;Output the service categeories
-        ;------------------------------
-OSCAT(SCL,PSTART)       ;
-        N IC,CSTART,EM,SC,SCTEXT
-        S CSTART=PSTART+3
-        W !,?PSTART,"Service categories:",?32,SCL
-        F IC=1:1:$L(SCL,",") D
-        .S SC=$P(SCL,",",IC)
-        .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
-        .W !,?CSTART,SC," - ",SCTEXT
-        .D CHECK(1)
-        Q
-        ;
-        ;Check for page throw
-        ;--------------------
-CHECK(LEAVE)    ;
-        S CNT=CNT+1
-        I CNT>(IOSL-BMARG-LEAVE) D PAGE S CNT=0
-        Q
-        ;
-        ;form feed to new page
-        ;---------------------
-PAGE    I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D
-        .S DIR(0)="E"
-        .W !
-        .D ^DIR K DIR
-        I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
-        W !
-        Q
+PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ; Called from PXRMXT/PXRMXTF
+ ;
+ ;
+ ;Display Template information
+START ;----------------------------
+ N PAGE,BMARG,DONE,SD,ED,DES,RDES,CDES,PSTART,PXRMOPT,IC,CNT
+ S PAGE=1,BMARG=0,DONE=0,SD="",ED="",PSTART=10,CNT=0
+ ;
+ D LITS^PXRMXPR1
+ ;
+ I PXRMREP="D" S PXRMOPT="Detailed Report"
+ I PXRMREP="S" S PXRMOPT="Summary Report"
+ W !!?(PSTART),"Report Title:",?32,$P(PXRMTMP,U,3)
+ W !?PSTART,"Report Type:",?32,$G(PXRMOPT)
+ W !?PSTART,"Patient Sample:",?32,PXRMFLD
+ I "LT"[PXRMSEL D
+ .W !,?PSTART,"Facility:" D FAC
+ I PXRMSEL'="L" W !,?PSTART,PXRMFLD,":" D ARRS
+ I PXRMSEL="L" D
+ .W !?PSTART,PXRMFLD,":",?32,DES
+ .I $E(PXRMLCSC,2)'="A" W ! D ARRS
+ I DONE Q
+ S IC="" F  S IC=$O(PXRMRCAT(IC)) Q:IC=""  D  Q:DONE
+ .W !,?PSTART W:IC=1 "Category:"
+ .W ?32,$P(PXRMRCAT(IC),U,3),?35,$P(PXRMRCAT(IC),U,2) D CHECK(1)
+ I DONE Q
+ S IC="" F  S IC=$O(PXRMREM(IC)) Q:IC=""  D  Q:DONE
+ .W !,?PSTART W:IC=1 "Reminder:"
+ .W ?32,$P(PXRMREM(IC),U,3),?35,$P(PXRMREM(IC),U,2) D CHECK(1)
+ I DONE Q
+ I PXRMSEL="P" W !,?PSTART,"All/Primary:",?32,CDES
+ W !?(PSTART),"Template Name:",?32,$P(PXRMTMP,U,2)
+ W !?PSTART,"Date last run:",?32,$S(RUN]"":RUN,1:"n/a")
+ I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART)
+EXIT Q
+ ;
+ ;Display selected teams/providers
+ ;--------------------------------
+ARRS N IC
+ S IC=""
+ I PXRMSEL="P" F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D  Q:DONE
+ .W:IC>1 ! W ?32,$P(PXRMPRV(IC),U,2) D CHECK(1)
+ I PXRMSEL="T" F  S IC=$O(PXRMPCM(IC)) Q:IC=""  D  Q:DONE
+ .W:IC>1 ! W ?32,$P(PXRMPCM(IC),U,2) D CHECK(1)
+ I PXRMSEL="O" F  S IC=$O(PXRMOTM(IC)) Q:IC=""  D  Q:DONE
+ .W:IC>1 ! W ?32,$P(PXRMOTM(IC),U,2) D CHECK(1)
+ I PXRMSEL="I" F  S IC=$O(PXRMPAT(IC)) Q:IC=""  D  Q:DONE
+ .W:IC>1 ! W ?32,$P(PXRMPAT(IC),U,2) D CHECK(1)
+ I PXRMSEL="R" F  S IC=$O(PXRMLIST(IC)) Q:IC=""  D  Q:DONE
+ .W:IC>1 ! W ?32,$P(PXRMLIST(IC),U,2) D CHECK(1)
+ I PXRMSEL="L" D
+ .I $E(PXRMLCSC)="H" F  S IC=$O(PXRMLCHL(IC)) Q:IC=""  D
+ ..W:IC>1 ! W ?32,$P(PXRMLCHL(IC),U) D CHECK(1)
+ .I $E(PXRMLCSC)="C" F  S IC=$O(PXRMCS(IC)) Q:IC=""  D
+ ..W:IC>1 ! W ?32,$P(PXRMCS(IC),U)," ",$P(PXRMCS(IC),U,3)
+ ..D CHECK(1)
+ .I $E(PXRMLCSC)="G" F  S IC=$O(PXRMCGRP(IC)) Q:IC=""  D
+ ..W:IC>1 ! W ?32,$P(PXRMCGRP(IC),U)," ",$P(PXRMCGRP(IC),U,2)
+ ..D CHECK(1)
+ Q
+ ;
+ ;Display selected Facilities
+ ;---------------------------
+FAC N IC
+ S IC=""
+ F  S IC=$O(PXRMFAC(IC)) Q:IC=""  D  Q:DONE
+ .W:IC>1 ! W ?32,$P(PXRMFAC(IC),U,2) D CHECK(1)
+ Q
+ ;
+ ;
+ ;Output the service categeories
+ ;------------------------------
+OSCAT(SCL,PSTART) ;
+ N IC,CSTART,EM,SC,SCTEXT
+ S CSTART=PSTART+3
+ W !,?PSTART,"Service categories:",?32,SCL
+ F IC=1:1:$L(SCL,",") D
+ .S SC=$P(SCL,",",IC)
+ .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM)
+ .W !,?CSTART,SC," - ",SCTEXT
+ .D CHECK(1)
+ Q
+ ;
+ ;Check for page throw
+ ;--------------------
+CHECK(LEAVE) ;
+ S CNT=CNT+1
+ I CNT>(IOSL-BMARG-LEAVE) D PAGE S CNT=0
+ Q
+ ;
+ ;form feed to new page
+ ;---------------------
+PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
+ .S DIR(0)="E"
+ .W !
+ .D ^DIR K DIR
+ I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
+ W !
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m

@@ -1 @@
-PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;11/27/2006
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRMYD,PXRMXD
-        ;
-        ;Option to Edit
-        ;--------------
-EDIT    ;
-        N DIDEL,DIE,DR K DTOUT,DUOUT
-        ;Edit report name, title and PXRMSEL (patient sample)
-        S DIE=810.1,DA=$P(PXRMTMP,U),DR=".01T;1.9;1.2",DIDEL=810.1
-        D ^DIE I $D(Y) S DUOUT=1 Q
-        ;Check if template has been deleted
-        I '$D(DA) Q
-        ;Get updated value of PXRMXSEL
-        N PXRMSEL,PXRMFUT S PXRMSEL=X
-        ;Needed for 1.6 validation - Prior/Future or Current/Admissions
-        ;N PXRMINP
-        ;Further fields depend on value in PXRMXSEL
-        I PXRMSEL="I" S DR="6T~R",PXRMINP=0
-        I PXRMSEL="R" S DR="14T",PXRMINP=0
-        I PXRMSEL="L" D  Q:$D(DUOUT)
-        .;Get location report type 
-        .S DR="3T;1.5R" D ^DIE I $D(Y) S DUOUT=1 Q
-        .N PXRMLCSC S PXRMLCSC=X,DR="",PXRMINP=0
-        .;All location reports - prompt for prior/future/current/admissions
-        .I PXRMLCSC="HAI" S PXRMINP=1,DR="1.6" Q
-        .I PXRMLCSC="HA" S PXRMINP=0,DR="1.6"
-        .I PXRMLCSC="CA" S PXRMINP=0,DR="1.6"
-        .D ^DIE I $D(Y) S DUOUT=1 Q
-        .S PXRMFUT=X,DR=""
-        .;Selected Location/Stop Code/Clinic Group fields 
-        .I PXRMLCSC="HS" D  Q:$D(DUOUT)
-        ..S DR="10T~R"
-        ..D ^DIE I $D(Y) S DUOUT=1 Q
-        ..;Determine if locations input are all wards
-        ..S PXRMINP=$$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN)
-        ..;Select Prior/Future or Current Inpatient/Admissions
-        ..S DR="1.6"
-        ..D ^DIE I $D(Y) S DUOUT=1 Q
-        ..S PXRMFUT=X,DR=""
-        .;Clinic Stop input and prior/future
-        .I PXRMLCSC="CS" S PXRMINP=0,DR="11T~R;1.6" D  I $G(DUOUT)=1 Q
-        ..D ^DIE I $D(Y) S DUOUT=1 Q
-        ..S PXRMFUT=X,DR=""
-        .;Clinic Group input and prior/future
-        .I PXRMLCSC="GS" S PXRMINP=0,DR="12T~R;1.6" D  I $G(DUOUT)=1 Q
-        ..D ^DIE I $D(Y) S DUOUT=1 Q
-        ..S PXRMFUT=X,DR=""
-        .;Service categories (except for inpatient reports)
-        .I PXRMINP=0,PXRMFUT'="F",PXRMFUT'="C" S DR=DR_";9T~R"
-        ;OE/RR teams
-        I PXRMSEL="O" S DR="7T~R"
-        ;PCMM Provider and Primary care/All
-        I PXRMSEL="P" S DR="4T~R;1.3"
-        ;PCMM teams
-        I PXRMSEL="T" S DR="3T~R;8T~R"
-        ;Report type (detail or summary)
-        S DR=DR_";1.4"
-        ;Print Locations without patients
-        S DR=DR_";1.7"
-        ;Reminder Categories
-        I $D(^PXRMPT(810.1,DA,12,0))>0 D
-        .N IEN,CNT,NODE
-        .S CNT=0,IEN=0 F  S IEN=$O(^PXRMPT(810.1,DA,12,IEN)) Q:IEN'>0  D
-        ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,12,IEN,0))
-        ..S PXRMTCAT(DA,CNT)=$P(NODE,U)_U_$P($G(^PXRMD(811.7,$P(NODE,U),0)),U)_U_$P(NODE,U,2)
-        S DR=DR_";13T"
-        ;Reminders
-        I $D(^PXRMPT(810.1,DA,1,0))>0 D
-        .N IEN,CNT,NODE,REMNODE
-        .S CNT=0,IEN=0 F  S IEN=$O(^PXRMPT(810.1,DA,1,IEN)) Q:IEN'>0  D
-        ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,1,IEN,0))
-        ..S REMNODE=$G(^PXD(811.9,$P(NODE,U),0))
-        ..S PXRMTREM(DA,CNT)=$P(NODE,U)_U_$P(REMNODE,U)_U_$P(NODE,U,2)_U_$P($G(REMNODE),U,3)
-        S DR=DR_";2T"
-        ;
-        ;Strip of any leading semi-colons
-        I $E(DR)=";" S DR=$P(DR,";",2,99)
-        ;
-        D ^DIE I $D(Y) S DUOUT=1 Q
-        ;
-        ;If all reminders have been deleted from the template disallow save
-        I +$P($G(^PXRMPT(810.1,DA,1,0)),U,4)=0 D
-        .;Check categories also
-        .I +$P($G(^PXRMPT(810.1,DA,12,0)),U,4)>0 D  Q
-        .. N CAT,CATIEN
-        .. S CAT=0 F  S CAT=$O(^PXRMPT(810.1,DA,12,CAT)) Q:+CAT'>0  D
-        ... S CATIEN=$P($G(^PXRMPT(810.1,DA,12,CAT,0)),U)
-        ... I +$P($G(^PXRMD(811.7,CATIEN,2,0)),U,4)<1 W !!,"** WARNING **",!,"Reminder Category "_$P($G(^PXRMD(811.7,CATIEN,0)),U)_" does not have any reminders assigned to it"
-        .S DUOUT=1
-        .W !!,"No reminders defined"
-        Q
-        ;
+PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ; Called from PXRMYD,PXRMXD
+ ;
+ ;Option to Edit
+ ;--------------
+EDIT ;
+ N DIDEL,DIE,DR K DTOUT,DUOUT
+ ;Edit report name, title and PXRMSEL (patient sample)
+ S DIE=810.1,DA=$P(PXRMTMP,U),DR=".01T;1.9;1.2",DIDEL=810.1
+ D ^DIE I $D(Y) S DUOUT=1 Q
+ ;Check if template has been deleted
+ I '$D(DA) Q
+ ;Get updated value of PXRMXSEL
+ N PXRMSEL,PXRMFUT S PXRMSEL=X
+ ;Needed for 1.6 validation - Prior/Future or Current/Admissions
+ ;N PXRMINP
+ ;Further fields depend on value in PXRMXSEL
+ I PXRMSEL="I" S DR="6T~R",PXRMINP=0
+ I PXRMSEL="R" S DR="14T",PXRMINP=0
+ I PXRMSEL="L" D  Q:$D(DUOUT)
+ .;Get location report type 
+ .S DR="3T;1.5R" D ^DIE I $D(Y) S DUOUT=1 Q
+ .N PXRMLCSC S PXRMLCSC=X,DR="",PXRMINP=0
+ .;All location reports - prompt for prior/future/current/admissions
+ .I PXRMLCSC="HAI" S PXRMINP=1,DR="1.6" Q
+ .I PXRMLCSC="HA" S PXRMINP=0,DR="1.6"
+ .I PXRMLCSC="CA" S PXRMINP=0,DR="1.6"
+ .D ^DIE I $D(Y) S DUOUT=1 Q
+ .S PXRMFUT=X,DR=""
+ .;Selected Location/Stop Code/Clinic Group fields 
+ .I PXRMLCSC="HS" D  Q:$D(DUOUT)
+ ..S DR="10T~R"
+ ..D ^DIE I $D(Y) S DUOUT=1 Q
+ ..;Determine if locations input are all wards
+ ..S PXRMINP=$$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN)
+ ..;Select Prior/Future or Current Inpatient/Admissions
+ ..S DR="1.6"
+ ..D ^DIE I $D(Y) S DUOUT=1 Q
+ ..S PXRMFUT=X,DR=""
+ .;Clinic Stop input and prior/future
+ .I PXRMLCSC="CS" S PXRMINP=0,DR="11T~R;1.6" D  I $G(DUOUT)=1 Q
+ ..D ^DIE I $D(Y) S DUOUT=1 Q
+ ..S PXRMFUT=X,DR=""
+ .;Clinic Group input and prior/future
+ .I PXRMLCSC="GS" S PXRMINP=0,DR="12T~R;1.6" D  I $G(DUOUT)=1 Q
+ ..D ^DIE I $D(Y) S DUOUT=1 Q
+ ..S PXRMFUT=X,DR=""
+ .;Service categories (except for inpatient reports)
+ .I PXRMINP=0,PXRMFUT'="F",PXRMFUT'="C" S DR=DR_";9T~R"
+ ;OE/RR teams
+ I PXRMSEL="O" S DR="7T~R"
+ ;PCMM Provider and Primary care/All
+ I PXRMSEL="P" S DR="4T~R;1.3"
+ ;PCMM teams
+ I PXRMSEL="T" S DR="3T~R;8T~R"
+ ;Report type (detail or summary)
+ S DR=DR_";1.4"
+ ;Reminder Categories
+ I $D(^PXRMPT(810.1,DA,12,0))>0 D
+ .N IEN,CNT,NODE
+ .S CNT=0,IEN=0 F  S IEN=$O(^PXRMPT(810.1,DA,12,IEN)) Q:IEN'>0  D
+ ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,12,IEN,0))
+ ..S PXRMTCAT(DA,CNT)=$P(NODE,U)_U_$P($G(^PXRMD(811.7,$P(NODE,U),0)),U)_U_$P(NODE,U,2)
+ S DR=DR_";13T"
+ ;Reminders
+ I $D(^PXRMPT(810.1,DA,1,0))>0 D
+ .N IEN,CNT,NODE,REMNODE
+ .S CNT=0,IEN=0 F  S IEN=$O(^PXRMPT(810.1,DA,1,IEN)) Q:IEN'>0  D
+ ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,1,IEN,0))
+ ..S REMNODE=$G(^PXD(811.9,$P(NODE,U),0))
+ ..S PXRMTREM(DA,CNT)=$P(NODE,U)_U_$P(REMNODE,U)_U_$P(NODE,U,2)_U_$P($G(REMNODE),U,3)
+ S DR=DR_";2T"
+ ;
+ ;Strip of any leading semi-colons
+ I $E(DR)=";" S DR=$P(DR,";",2,99)
+ ;
+ D ^DIE I $D(Y) S DUOUT=1 Q
+ ;
+ ;If all reminders have been deleted from the template disallow save
+ I +$P($G(^PXRMPT(810.1,DA,1,0)),U,4)=0 D
+ .;Check categories also
+ .I +$P($G(^PXRMPT(810.1,DA,12,0)),U,4)>0 D  Q
+ .. N CAT,CATIEN
+ .. S CAT=0 F  S CAT=$O(^PXRMPT(810.1,DA,12,CAT)) Q:+CAT'>0  D
+ ... S CATIEN=$P($G(^PXRMPT(810.1,DA,12,CAT,0)),U)
+ ... I +$P($G(^PXRMD(811.7,CATIEN,2,0)),U,4)<1 W !!,"** WARNING **",!,"Reminder Category "_$P($G(^PXRMD(811.7,CATIEN,0)),U)_" does not have any reminders assigned to it"
+ .S DUOUT=1
+ .W !!,"No reminders defined"
+ Q
+ ;

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m

@@ -1 @@
-PXRMXTF ; SLC/PJH - Reminder Reports Template Filing ;05/02/2002
-        ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRMXTA
-        ;
-        ;Select template name and file
-        ;-----------------------------
-START   N NEWIEN,NEWTEMP,OLDTEMP
-        ;Save original name
-        S OLDTEMP=$P(PXRMTMP,U,2)
-        ;Reset PXRMTMP in case the template name field has been edited
-        S $P(PXRMTMP,U,2)=$P($G(^PXRMPT(810.1,$P(PXRMTMP,U,1),0)),U)
-        ;Redisplay changes made
-        D REDISP
-        ;Prompt template name
-        D NAME
-        ;Rollback ^DIE changes if edit is abandoned
-        I $D(DTOUT)!$D(DUOUT) D ROLL Q
-        ;
-        I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP=OLDTEMP D MESS(1,NEWTEMP)
-        I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP'=OLDTEMP D MESS(3,OLDTEMP,NEWTEMP)
-        ;
-        ;If a new template ID is selected then create a new template
-        I NEWTEMP'=$P(PXRMTMP,U,2) D  I $D(MSG) S DTOUT=1 Q
-        .;Create template header
-        .D HEADER
-        .;Save edited template detail to new template name
-        .D REFILE Q:$D(MSG)
-        .;Save Message
-        .D MESS(2,NEWTEMP)
-        .;File original arrays to old template (rollback ^DIE changes)
-        .D FILE^PXRMXTU(PXRMTMP,1,1)
-        .;Set selected template ID
-        .S PXRMTMP=NEWIEN
-        ;
-        ;Reload arrays
-        D LOAD^PXRMXT I $D(MSG) S DTOUT=1 Q
-EXIT    Q
-        ;
-        ;Rename edited template
-        ;----------------------
-NAME    N X,Y,TEXT,DIR
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="FAU"_U_"3:30"_U_"K:'$$OK^PXRMXTF(X) X"
-        S DIR("A")="STORE REPORT LOGIC IN TEMPLATE NAME: "
-        S DIR("B")=$P(PXRMTMP,U,2)
-        S DIR("?")="Enter template name. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMXTF(1)"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        S NEWTEMP=Y
-        Q
-        ;
-        ;Check if the template name is in use
-        ;------------------------------------
-OK(NAME)        ;
-        ;Original template name may be used
-        I X=DIR("B") Q 1
-        I $E(DIR("B"),1,$L(X))=X Q 0
-        ;Else check if template name defined
-        I '$D(^PXRMPT(810.1,"B",NAME)) Q 1
-        Q 0
-        ;
-        ;Create Template header and get IEN
-        ;----------------------------------
-HEADER  N DATA,IEN,NUM
-        ;Otherwise create a new entry
-        S DATA=$G(^PXRMPT(810.1,0)),IEN=$P(DATA,U,3),NUM=$P(DATA,U,4)
-        F  S IEN=IEN+1 Q:'$D(^PXRMPT(IEN,0))
-        S ^PXRMPT(810.1,IEN,0)=NEWTEMP
-        S ^PXRMPT(810.1,"B",NEWTEMP,IEN)=""
-        S $P(^PXRMPT(810.1,0),U,3)=IEN,$P(^PXRMPT(810.1,0),U,4)=NUM+1
-        S NEWIEN=IEN_U_NEWTEMP
-        Q
-        ;
-        ;Redisplay edited template details
-        ;---------------------------------------------
-REDISP  N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
-        N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
-        N PXRMLIST,TITLE
-        ;
-        ;Load temporary arrays from edited template PXRMTMP
-        D LOAD^PXRMXT I $D(MSG) Q
-        ;Clear last run date
-        S RUN=""
-        ;Display
-        D ^PXRMXTD
-        ;
-        Q
-        ;
-        ;Copy edited template details to new template
-        ;---------------------------------------------
-REFILE  N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
-        N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
-        N PXRMLIST,TITLE
-        ;
-        ;Load temporary arrays from edited template PXRMTMP
-        D LOAD^PXRMXT I $D(MSG) Q
-        ;Clear last run date
-        S RUN=""
-        ;Save arrays to new ID
-        D FILE^PXRMXTU(NEWIEN,1,0) Q:$D(MSG)
-        Q
-        ;
-        ;Rollback changes (also called from PXRMXTA)
-        ;----------------
-ROLL    ;
-        D FILE^PXRMXTU(PXRMTMP,1,1)
-        I $D(MSG) S DTOUT=1 Q
-        ;Changes not saved message
-        D MESS(0,$P(PXRMTMP,U,2))
-        Q
-        ;
-        ;Filing messages
-        ;---------------
-MESS(MODE,INP,INP1)     ;
-        I MODE=0 W !,"Changes to template '"_INP_"' have not been saved" Q
-        I MODE=1 W !,"Changes to template '"_INP_"' have been saved"
-        I MODE=2 W !,"A new template '"_INP_"' has been created"
-        I MODE=3 W !,"Template '"_INP_"' renamed as '"_INP1_"'"
-        I MODE=4 W !,"Template '"_INP_"' not saved"
-        Q
-        ;
-        ;General help text routine. Write out the text in the HTEXT array
-        ;----------------------------------------------------------------
-HELP(CALL)      ;
-        N HTEXT
-        N DIWF,DIWL,DIWR,IC
-        S DIWF="C70",DIWL=0,DIWR=70
-        ;
-        I CALL=1 D
-        .S HTEXT(1)="To save or rename the existing template use the default"
-        .S HTEXT(2)="name. To create a new template and leave the original "
-        .S HTEXT(3)="unchanged enter a different template name "
-        .S HTEXT(4)="that is not in use."
-        ;
-        K ^UTILITY($J,"W")
-        S IC=""
-        F  S IC=$O(HTEXT(IC)) Q:IC=""  D
-        . S X=HTEXT(IC)
-        . D ^DIWP
-        W !
-        S IC=0
-        F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
-        . W !,^UTILITY($J,"W",0,IC,0)
-        K ^UTILITY($J,"W")
-        W !
-        Q
+PXRMXTF ; SLC/PJH - Reminder Reports Template Filing ;05/02/2002
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ; 
+ ; Called from PXRMXTA
+ ;
+ ;Select template name and file
+ ;-----------------------------
+START N NEWIEN,NEWTEMP,OLDTEMP
+ ;Save original name
+ S OLDTEMP=$P(PXRMTMP,U,2)
+ ;Reset PXRMTMP in case the template name field has been edited
+ S $P(PXRMTMP,U,2)=$P($G(^PXRMPT(810.1,$P(PXRMTMP,U,1),0)),U)
+ ;Redisplay changes made
+ D REDISP
+ ;Prompt template name
+ D NAME
+ ;Rollback ^DIE changes if edit is abandoned
+ I $D(DTOUT)!$D(DUOUT) D ROLL Q
+ ;
+ I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP=OLDTEMP D MESS(1,NEWTEMP)
+ I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP'=OLDTEMP D MESS(3,OLDTEMP,NEWTEMP)
+ ;
+ ;If a new template ID is selected then create a new template
+ I NEWTEMP'=$P(PXRMTMP,U,2) D  I $D(MSG) S DTOUT=1 Q
+ .;Create template header
+ .D HEADER
+ .;Save edited template detail to new template name
+ .D REFILE Q:$D(MSG)
+ .;Save Message
+ .D MESS(2,NEWTEMP)
+ .;File original arrays to old template (rollback ^DIE changes)
+ .D FILE^PXRMXTU(PXRMTMP,1,1)
+ .;Set selected template ID
+ .S PXRMTMP=NEWIEN
+ ;
+ ;Reload arrays
+ D LOAD^PXRMXT I $D(MSG) S DTOUT=1 Q
+EXIT Q
+ ;
+ ;Rename edited template
+ ;----------------------
+NAME N X,Y,TEXT,DIR
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="FAU"_U_"3:30"_U_"K:'$$OK^PXRMXTF(X) X"
+ S DIR("A")="STORE REPORT LOGIC IN TEMPLATE NAME: "
+ S DIR("B")=$P(PXRMTMP,U,2)
+ S DIR("?")="Enter template name. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMXTF(1)"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ S NEWTEMP=Y
+ Q
+ ;
+ ;Check if the template name is in use
+ ;------------------------------------
+OK(NAME) ;
+ ;Original template name may be used
+ I X=DIR("B") Q 1
+ I $E(DIR("B"),1,$L(X))=X Q 0
+ ;Else check if template name defined
+ I '$D(^PXRMPT(810.1,"B",NAME)) Q 1
+ Q 0
+ ;
+ ;Create Template header and get IEN
+ ;----------------------------------
+HEADER N DATA,IEN,NUM
+ ;Otherwise create a new entry
+ S DATA=$G(^PXRMPT(810.1,0)),IEN=$P(DATA,U,3),NUM=$P(DATA,U,4)
+ F  S IEN=IEN+1 Q:'$D(^PXRMPT(IEN,0))
+ S ^PXRMPT(810.1,IEN,0)=NEWTEMP
+ S ^PXRMPT(810.1,"B",NEWTEMP,IEN)=""
+ S $P(^PXRMPT(810.1,0),U,3)=IEN,$P(^PXRMPT(810.1,0),U,4)=NUM+1
+ S NEWIEN=IEN_U_NEWTEMP
+ Q
+ ;
+ ;Redisplay edited template details
+ ;---------------------------------------------
+REDISP N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
+ N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
+ N PXRMLIST,TITLE
+ ;
+ ;Load temporary arrays from edited template PXRMTMP
+ D LOAD^PXRMXT I $D(MSG) Q
+ ;Clear last run date
+ S RUN=""
+ ;Display
+ D ^PXRMXTD
+ ;
+ Q
+ ;
+ ;Copy edited template details to new template
+ ;---------------------------------------------
+REFILE N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
+ N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
+ N PXRMLIST,TITLE
+ ;
+ ;Load temporary arrays from edited template PXRMTMP
+ D LOAD^PXRMXT I $D(MSG) Q
+ ;Clear last run date
+ S RUN=""
+ ;Save arrays to new ID
+ D FILE^PXRMXTU(NEWIEN,1,0) Q:$D(MSG)
+ Q
+ ;
+ ;Rollback changes (also called from PXRMXTA)
+ ;----------------
+ROLL ;
+ D FILE^PXRMXTU(PXRMTMP,1,1)
+ I $D(MSG) S DTOUT=1 Q
+ ;Changes not saved message
+ D MESS(0,$P(PXRMTMP,U,2))
+ Q
+ ;
+ ;Filing messages
+ ;---------------
+MESS(MODE,INP,INP1) ;
+ I MODE=0 W !,"Changes to template '"_INP_"' have not been saved" Q
+ I MODE=1 W !,"Changes to template '"_INP_"' have been saved"
+ I MODE=2 W !,"A new template '"_INP_"' has been created"
+ I MODE=3 W !,"Template '"_INP_"' renamed as '"_INP1_"'"
+ I MODE=4 W !,"Template '"_INP_"' not saved"
+ Q
+ ;
+ ;General help text routine. Write out the text in the HTEXT array
+ ;----------------------------------------------------------------
+HELP(CALL) ;
+ N HTEXT
+ N DIWF,DIWL,DIWR,IC
+ S DIWF="C70",DIWL=0,DIWR=70
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="To save or rename the existing template use the default"
+ .S HTEXT(2)="name. To create a new template and leave the original "
+ .S HTEXT(3)="unchanged enter a different template name "
+ .S HTEXT(4)="that is not in use."
+ ;
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
+ W !
+ Q

WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m

@@ -1 @@
-PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/27/2006
-        ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
-        ; 
-        ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR)
-        ;
-        ;Option to create a new template
-        ;-------------------------------
-START   N PXRMASK,MSG D ASK(.PXRMASK)
-        I $G(PXRMASK)="Y" D SAVE
-EXIT    Q
-        ;
-        ;Ask name for new template
-        ;-------------------------
-SAVE    N X,Y,DIC,DLAYGO
-SAV1    S DIC=810.1,DLAYGO=DIC,DIC(0)="QAELX"
-        S DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: "
-        W !
-        D ^DIC
-        I X="" W !,"A template name must be entered" G SAV1
-        I X=(U_U) S DTOUT=1
-        I Y=-1 S DUOUT=1 W !,"Details not saved" Q
-        I $D(DTOUT)!$D(DUOUT) Q
-        ;Check
-        I ($P(Y,U,3)'=1) W !,"This template name already exists" G SAV1
-        ;Get template name and title
-        S PXRMTMP=Y,TITLE=$P($G(^PXRMPT(810.1,$P(Y,U),0)),U,2)
-        S $P(PXRMTMP,U,3)=TITLE
-        ;File details
-        D FILE(Y,1,0)
-        ;File not saved message
-        I $D(MSG) D  Q
-        .N DA,DIK
-        .S DA=$P(Y,U),DIK="^PXRMPT(810.1," D ^DIK
-        .D MESS^PXRMXTF(4,$P(PXRMTMP,U,2))
-        ;File saved message
-        D MESS^PXRMXTF(1,$P(PXRMTMP,U,2))
-        Q
-        ;
-        ;File template detail
-        ;--------------------
-FILE(INP,UPD,CLR)       ;
-        N CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X
-        S FDAIEN(1)=$P(INP,U),NAME=$P(INP,U,2)
-        ;Save exit flags - needed for rollback
-        N DUOUT,DTOUT
-        ;
-        ;Update or Add
-        S MODE=$S(UPD:(FDAIEN(1)_","),1:"+1,")
-        ;Delete entries from existing template
-        I CLR D
-        .N DA S DA=0
-        .F  S DA=$O(^PXRMPT(810.1,FDAIEN(1),DA)) Q:'DA  D
-        ..K ^PXRMPT(810.1,FDAIEN(1),DA)
-        ;
-        I PXRMSEL="L" S X=PXRMLCSC,PXRMLCSC=$P(PXRMLCSC,U)
-        ;
-        N MREF,XREF
-        D XREF^PXRMXTB
-        ;
-        ;Save single fields into FDA
-        F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP","PXRMPML" D
-        .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
-        F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D
-        .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
-        ;
-        I PXRMSEL="L" S PXRMLCSC=X
-        ;
-        ;Save Arrays into FDA
-        ;
-        ;Reminder Items
-        S CNT=1
-        D SUB1(.PXRMREM,"810.12",1)
-        ;Save Facility codes
-        D SUB1(.PXRMFAC,"810.13",1)
-        ;Save Provider codes
-        D SUB1(.PXRMPRV,"810.14",1)
-        ;Save Patient codes
-        D SUB1(.PXRMPAT,"810.16",1)
-        ;Save OE/RR Team codes
-        D SUB1(.PXRMOTM,"810.17",1)
-        ;Save PCMM Team codes
-        D SUB1(.PXRMPCM,"810.18",1)
-        ;Save Hospital Location codes
-        D SUB1(.PXRMLCHL,"810.11",2)
-        ;Save Clinic Stop codes
-        D SUB1(.PXRMCS,"810.111",2)
-        ;Save Clinic groups
-        D SUB1(.PXRMCGRP,"810.112",1)
-        ;Save Reminder Categories
-        D SUB1(.PXRMRCAT,"810.113",1)
-        ;Save Patient lists
-        D SUB1(.PXRMLIST,"810.114",1)
-        ;
-        ;Update template file
-        D UPDATE^DIE("S","FDA","FDAIEN","MSG")
-        ;
-        I $D(MSG) D
-        .W !!,"Update failed, UPDATE^DIE returned the following error message:"
-        .S IC="MSG"
-        .F  S IC=$Q(@IC) Q:IC=""  W !,IC,"=",@IC
-        .W !,"Examine the above error message for the reason.",!
-        .H 2
-        Q
-        ;
-        ;Save arrays into FDA
-        ;--------------------
-SUB1(OUTPUT,VAR,PIECE)  ;
-        S IC=""
-        ;This is use for saving individual reminders back to the original
-        ;template
-        I VAR=810.12,$D(PXRMTREM($P(INP,U)))>0 D  Q
-        .F  S IC=$O(PXRMTREM($P(INP,U),IC)) Q:IC=""  D
-        ..S INT=$P(PXRMTREM($P(INP,U),IC),U,PIECE),CNT=CNT+1
-        ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
-        ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
-        ;
-        ;This is use for saving individual reminders category back to the 
-        ;original template
-        I VAR=810.113,$D(PXRMTCAT($P(INP,U)))>0 D  Q
-        .F  S IC=$O(PXRMTCAT($P(INP,U),IC)) Q:IC=""  D
-        ..S INT=$P(PXRMTCAT($P(INP,U),IC),U,PIECE),CNT=CNT+1
-        ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
-        ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
-        ;
-        ;this is use for saving everything else to the template
-        F  S IC=$O(OUTPUT(IC)) Q:IC=""  D
-        .S INT=$P(OUTPUT(IC),U,PIECE),CNT=CNT+1
-        .S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
-        .;Save Display order for reminders and categories
-        .I (VAR=810.12)!(VAR=810.113) S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
-        Q
-        ;
-        ;Save Service Categories into FDA
-        ;--------------------------------
-SUB2(FLD,VAR)   ;
-        F IC=1:1 S INT=$E(@FLD,IC) Q:INT=""  D
-        .S CNT=CNT+1,FDA(VAR,"+"_CNT_","_MODE,.01)=INT
-        Q
-        ;
-        ;
-        ;Option to save a new template
-        ;-----------------------------
-ASK(YESNO)      ;
-        N X,Y,TEXT
-        K DIROUT,DIRUT,DTOUT,DUOUT
-        S DIR(0)="YA0"
-        S DIR("A")="Create a new report template: "
-        S DIR("B")="N"
-        S DIR("?")="Enter Y or N. For detailed help type ??"
-        S DIR("??")=U_"D HELP^PXRMXTU(1)"
-        W !
-        D ^DIR K DIR
-        I $D(DIROUT) S DTOUT=1
-        I $D(DTOUT)!($D(DUOUT)) Q
-        S YESNO=$E(Y(0))
-        Q
-        ;
-        ;General help text routine. Write out the text in the HTEXT array
-        ;----------------------------------------------------------------
-HELP(CALL)      ;
-        N HTEXT
-        N DIWF,DIWL,DIWR,IC
-        S DIWF="C70",DIWL=0,DIWR=70
-        ;
-        I CALL=1 D
-        .S HTEXT(1)="Enter 'Y' to save the reporting parameters as a report"
-        .S HTEXT(2)="template from which the report may be re-run in future."
-        ;
-        K ^UTILITY($J,"W")
-        S IC=""
-        F  S IC=$O(HTEXT(IC)) Q:IC=""  D
-        . S X=HTEXT(IC)
-        . D ^DIWP
-        W !
-        S IC=0
-        F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
-        . W !,^UTILITY($J,"W",0,IC,0)
-        K ^UTILITY($J,"W")
-        W !
-        Q
-        ;
-        ;Save template info to new name
-        ;------------------------------
-COPY    N PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
-        N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
-        ;Load arrays from original template PXRMTMP
-        D LOAD^PXRMXT I $D(MSG) Q
-        ;Clear last run date
-        S RUN=""
-        ;Save arrays to new ID
-        D FILE(NEWTEMP,0)
-        Q
-        ;
-        ;Update print template last run date (called from PXRMYPR/PXRMXPR)
-        ;-----------------------------------------------------------------
-UPD     S ^PXRMPT(810.1,$P(PXRMTMP,U),7)=PXRMXST
-        Q
-        ;
-        ;Called as an input transform for 810.1/NAME
-        ;-------------------------------------------
-NAME    Q:'$D(X)  Q:X=""  Q:$G(PXRMTYP)=""
-        ;Disallow duplicate template names
-        Q:'$D(^PXRMPT(810.1,"B",X))
-        W !,"This template name already exists" K X
-        Q
-        ;
-        ;Called as an input transform for 810.1/PXRMFD
-        ;---------------------------------------------
-INP     Q:'$D(X)  Q:X=""
-        ;If inpatient wards prompt only for Admissions/Current Patients
-        I $G(PXRMINP),"FP"[X D
-        .W !,"Select either Inpatient Admissions or Current Inpatients" K X
-        ;If other locations prompt only for Prior visits/Future Appts
-        I '$G(PXRMINP),"AC"[X D
-        .W !,"Select either Future Appointments or Prior Visits" K X
-        Q
+PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ; 
+ ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR)
+ ;
+ ;Option to create a new template
+ ;-------------------------------
+START N PXRMASK,MSG D ASK(.PXRMASK)
+ I $G(PXRMASK)="Y" D SAVE
+EXIT Q
+ ;
+ ;Ask name for new template
+ ;-------------------------
+SAVE N X,Y,DIC,DLAYGO
+SAV1 S DIC=810.1,DLAYGO=DIC,DIC(0)="QAELX"
+ S DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: "
+ W !
+ D ^DIC
+ I X="" W !,"A template name must be entered" G SAV1
+ I X=(U_U) S DTOUT=1
+ I Y=-1 S DUOUT=1 W !,"Details not saved" Q
+ I $D(DTOUT)!$D(DUOUT) Q
+ ;Check
+ I ($P(Y,U,3)'=1) W !,"This template name already exists" G SAV1
+ ;Get template name and title
+ S PXRMTMP=Y,TITLE=$P($G(^PXRMPT(810.1,$P(Y,U),0)),U,2)
+ S $P(PXRMTMP,U,3)=TITLE
+ ;File details
+ D FILE(Y,1,0)
+ ;File not saved message
+ I $D(MSG) D  Q
+ .N DA,DIK
+ .S DA=$P(Y,U),DIK="^PXRMPT(810.1," D ^DIK
+ .D MESS^PXRMXTF(4,$P(PXRMTMP,U,2))
+ ;File saved message
+ D MESS^PXRMXTF(1,$P(PXRMTMP,U,2))
+ Q
+ ;
+ ;File template detail
+ ;--------------------
+FILE(INP,UPD,CLR) ;
+ N CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X
+ S FDAIEN(1)=$P(INP,U),NAME=$P(INP,U,2)
+ ;Save exit flags - needed for rollback
+ N DUOUT,DTOUT
+ ;
+ ;Update or Add
+ S MODE=$S(UPD:(FDAIEN(1)_","),1:"+1,")
+ ;Delete entries from existing template
+ I CLR D
+ .N DA S DA=0
+ .F  S DA=$O(^PXRMPT(810.1,FDAIEN(1),DA)) Q:'DA  D
+ ..K ^PXRMPT(810.1,FDAIEN(1),DA)
+ ;
+ I PXRMSEL="L" S X=PXRMLCSC,PXRMLCSC=$P(PXRMLCSC,U)
+ ;
+ N MREF,XREF
+ D XREF^PXRMXTB
+ ;
+ ;Save single fields into FDA
+ F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP" D
+ .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
+ F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D
+ .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
+ ;
+ I PXRMSEL="L" S PXRMLCSC=X
+ ;
+ ;Save Arrays into FDA
+ ;
+ ;Reminder Items
+ S CNT=1
+ D SUB1(.PXRMREM,"810.12",1)
+ ;Save Facility codes
+ D SUB1(.PXRMFAC,"810.13",1)
+ ;Save Provider codes
+ D SUB1(.PXRMPRV,"810.14",1)
+ ;Save Patient codes
+ D SUB1(.PXRMPAT,"810.16",1)
+ ;Save OE/RR Team codes
+ D SUB1(.PXRMOTM,"810.17",1)
+ ;Save PCMM Team codes
+ D SUB1(.PXRMPCM,"810.18",1)
+ ;Save Hospital Location codes
+ D SUB1(.PXRMLCHL,"810.11",2)
+ ;Save Clinic Stop codes
+ D SUB1(.PXRMCS,"810.111",2)
+ ;Save Clinic groups
+ D SUB1(.PXRMCGRP,"810.112",1)
+ ;Save Reminder Categories
+ D SUB1(.PXRMRCAT,"810.113",1)
+ ;Save Patient lists
+ D SUB1(.PXRMLIST,"810.114",1)
+ ;
+ ;Update template file
+ D UPDATE^DIE("S","FDA","FDAIEN","MSG")
+ ;
+ I $D(MSG) D
+ .W !!,"Update failed, UPDATE^DIE returned the following error message:"
+ .S IC="MSG"
+ .F  S IC=$Q(@IC) Q:IC=""  W !,IC,"=",@IC
+ .W !,"Examine the above error message for the reason.",!
+ .H 2
+ Q
+ ;
+ ;Save arrays into FDA
+ ;--------------------
+SUB1(OUTPUT,VAR,PIECE) ;
+ S IC=""
+ ;This is use for saving individual reminders back to the original
+ ;template
+ I VAR=810.12,$D(PXRMTREM($P(INP,U)))>0 D  Q
+ .F  S IC=$O(PXRMTREM($P(INP,U),IC)) Q:IC=""  D
+ ..S INT=$P(PXRMTREM($P(INP,U),IC),U,PIECE),CNT=CNT+1
+ ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
+ ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
+ ;
+ ;This is use for saving individual reminders category back to the 
+ ;original template
+ I VAR=810.113,$D(PXRMTCAT($P(INP,U)))>0 D  Q
+ .F  S IC=$O(PXRMTCAT($P(INP,U),IC)) Q:IC=""  D
+ ..S INT=$P(PXRMTCAT($P(INP,U),IC),U,PIECE),CNT=CNT+1
+ ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
+ ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
+ ;
+ ;this is use for saving everything else to the template
+ F  S IC=$O(OUTPUT(IC)) Q:IC=""  D
+ .S INT=$P(OUTPUT(IC),U,PIECE),CNT=CNT+1
+ .S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
+ .;Save Display order for reminders and categories
+ .I (VAR=810.12)!(VAR=810.113) S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
+ Q
+ ;
+ ;Save Service Categories into FDA
+ ;--------------------------------
+SUB2(FLD,VAR) ;
+ F IC=1:1 S INT=$E(@FLD,IC) Q:INT=""  D
+ .S CNT=CNT+1,FDA(VAR,"+"_CNT_","_MODE,.01)=INT
+ Q
+ ;
+ ;
+ ;Option to save a new template
+ ;-----------------------------
+ASK(YESNO) ;
+ N X,Y,TEXT
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="YA0"
+ S DIR("A")="Create a new report template: "
+ S DIR("B")="N"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ S DIR("??")=U_"D HELP^PXRMXTU(1)"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ S YESNO=$E(Y(0))
+ Q
+ ;
+ ;General help text routine. Write out the text in the HTEXT array
+ ;----------------------------------------------------------------
+HELP(CALL) ;
+ N HTEXT
+ N DIWF,DIWL,DIWR,IC
+ S DIWF="C70",DIWL=0,DIWR=70
+ ;
+ I CALL=1 D
+ .S HTEXT(1)="Enter 'Y' to save the reporting parameters as a report"
+ .S HTEXT(2)="template from which the report may be re-run in future."
+ ;
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
+ W !
+ Q
+ ;
+ ;Save template info to new name
+ ;------------------------------
+COPY N PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
+ N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
+ ;Load arrays from original template PXRMTMP
+ D LOAD^PXRMXT I $D(MSG) Q
+ ;Clear last run date
+ S RUN=""
+ ;Save arrays to new ID
+ D FILE(NEWTEMP,0)
+ Q
+ ;
+ ;Update print template last run date (called from PXRMYPR/PXRMXPR)
+ ;-----------------------------------------------------------------
+UPD S ^PXRMPT(810.1,$P(PXRMTMP,U),7)=PXRMXST
+ Q
+ ;
+ ;Called as an input transform for 810.1/NAME
+ ;-------------------------------------------
+NAME Q:'$D(X)  Q:X=""  Q:$G(PXRMTYP)=""
+ ;Disallow duplicate template names
+ Q:'$D(^PXRMPT(810.1,"B",X))
+ W !,"This template name already exists" K X
+ Q
+ ;
+ ;Called as an input transform for 810.1/PXRMFD
+ ;---------------------------------------------
+INP Q:'$D(X)  Q:X=""
+ ;If inpatient wards prompt only for Admissions/Current Patients
+ I $G(PXRMINP),"FP"[X D
+ .W !,"Select either Inpatient Admissions or Current Inpatients" K X
+ ;If other locations prompt only for Prior visits/Future Appts
+ I '$G(PXRMINP),"AC"[X D
+ .W !,"Select either Future Appointments or Prior Visits" K X
+ Q