Index: /qrda/C0Q/trunk/p/C0QERTIM.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QERTIM.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QERTIM.m	(revision 1223)
@@ -0,0 +1,58 @@
+C0QERTIM	; Time from admission to leaving a hospital location ;
+	;;0.1;C0Q;;;Build 13
+EN	;Get Location
+	S DIC=42,DIC(0)="AEMQ" D ^DIC I Y<1 G EXIT
+	S LOCATION=+Y
+	;Start date
+	S %DT="AE",%DT("A")="Start DATE: " D ^%DT G:Y=-1 EXIT S START=Y
+	;End date
+	S %DT="AE",%DT("A")="Stop DATE: " D ^%DT G:Y=-1 EXIT S STOP=Y
+	;select device:
+	S %ZIS="Q" D ^%ZIS G EXIT:POP
+	I $D(IO("Q")) D  G EXIT
+	. S ZTRTN="DQ^C0QERTIM",ZTDESC="Time from admission to leaving a hospital location"
+	. S ZTSAVE("LOCATION")="",ZTSAVE("START")="",ZTSAVE("STOP")=""
+	. D ^%ZTLOAD D HOME^%ZIS K IO("Q")
+	. Q
+DQ	; Get down to business
+	;sort on admit date/time in file 45, screen on LOSING WARD in sub-file 535.
+	;^DGPT("AF",date/time,DA)
+	S PATCOUNT=0,ADMITIME=START
+	F  S ADMITIME=$O(^DGPT("AF",ADMITIME)) Q:ADMITIME'>0  D
+	. Q:ADMITIME>STOP
+	. ;FMIN from ADMISSION DATE piece 2
+	. S X=ADMITIME D H^%DTC S FMINDAY=%H,FMINSEC=%T
+	. S D0="" F  S D0=$O(^DGPT("AF",ADMITIME,D0)) Q:D0'>0  D
+	. . S D1=0 F  S D1=$O(^DGPT(D0,535,D1)) Q:D1'>0  D
+	. . . ;Losing ward in piece 6 of ^DGPT(D0,535,D1,0)
+	. . . Q:$P($G(^DGPT(D0,535,D1,0)),U,6)'=LOCATION
+	. . . ;FMOUT from MOVEMENT DATE on leaving in piece 10
+	. . . S X=$P($G(^DGPT(D0,535,D1,0)),U,10) D H^%DTC S FMOUTDAY=%H,FMOUTSEC=%T
+	. . . I FMINDAY=FMOUTDAY S MINUTES=$P((FMOUTSEC-FMINSEC)/60,".")
+	. . . I FMINDAY'=FMOUTDAY D
+	. . . . S DIFFDAY=FMOUTDAY-FMINDAY
+	. . . . S MINUTES=1440*(DIFFDAY-1)+$P((FMOUTSEC+86400-FMINSEC)/60,".")
+	. . . . Q
+	. . . S PATCOUNT=PATCOUNT+1
+	. . . S ^TMP($J,"PATIENTS",$P(^DPT(+^DGPT(D0,0),0),U))=MINUTES
+	. . . S ^TMP($J,"MINUTES",MINUTES)=1+$G(^TMP($J,"MINUTES",MINUTES))
+	. . . Q
+	. . Q
+	. Q
+	U IO W @IOF
+	;list median time from Admission to leaving hospital LOCATION
+	S MID=$P(PATCOUNT/2,"."),SUM=0
+	S MEDIAN=0 F  S MEDIAN=$O(^TMP($J,"MINUTES",MEDIAN)) Q:MEDIAN'>0  D
+	. S SUM=SUM+^TMP($J,"MINUTES",MEDIAN) Q:SUM>MID
+	. Q
+	W "The median time spent in ",$P(^DIC(42,LOCATION,0),U)," is ",MEDIAN," minutes.",!
+	W !,"Patient",?40,"Minutes in ",$P(^DIC(42,LOCATION,0),U)
+	;list patient and time from admission to leaving the location
+	S PATIENT="" F  S PATIENT=$O(^TMP($J,"PATIENTS",PATIENT)) Q:PATIENT=""  D
+	. W !,PATIENT,?40," ",^TMP($J,"PATIENTS",PATIENT)
+EXIT	; DO CLEANUP
+	S:$D(ZTQUEUED) ZTREQ="@"
+	K DIC,START,STOP,LOCATION,PATCOUNT,ADMITIME,FMINDAY,FMINSEC,FMOUTDAY,FMOUTSEC
+	K POP,D0,D1,DIFFDAY,MINUTES,MID,MEDIAN,PATIENT,^TMP($J)
+	Q
+	
Index: /qrda/C0Q/trunk/p/C0QGMRAD.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QGMRAD.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QGMRAD.m	(revision 1223)
@@ -0,0 +1,118 @@
+C0QGMRAD	;HIRMFO/RM,WAA-UTILITY TO GATHER PATIENT DATA ;1/15/98  13:47
+	;;4.0;Adverse Reaction Tracking;**2,10**;Mar 29, 1996;Build 13
+EN1	; ENTRY TO GATHER PATIENT A/AR DATA
+	;INPUT VARIABLES:
+	;
+	; DFN             Pointer to Patient file.
+	; GMRA (OPTIONAL) A^B^C   DEFAULT="0^0^111^0" **LOCAL
+	;    where  A = 0 return all reactions (allergic/non-allergic).
+	;               1 return allergies only.
+	;               2 return non-allergies only.
+	;           B = 0 return all data (verified or non-verified).
+	;               1 return only verified data.
+	;               2 return only non-verified data.
+	;           C = X_Y_Z
+	;               where X, Y, and Z are either 0 or 1.  1 would mean to
+	;               return an Adverse Reaction of that particular type, 
+	;               and zero means do not return an Adverse Reaction of 
+	;               that type.
+	;               X is for TYPE=OTHER
+	;               Y is for TYPE=FOOD
+	;               Z is for TYPE=DRUG.
+	;               E.g., 001 (return drug only), 111 (returns all types),
+	;               and 010 (returns food only).
+	;         **LOCAL
+	;           D = 0 return both Observed and Historical
+	;               1 return only Observed
+	;         **LOCAL
+	;OUTPUT VARIABLES:
+	; GMRAL = 1 if patient has Adverse Reaction
+	;         0 if patient has no known Adverse Reaction
+	;      null if patient has not been asked about Adverse Reaction
+	; GMRAL(PTR TO 120.8) = A^B^C^D^E^F^G^H^I
+	;    where A = Pointer to Patient file.
+	;          B = Free text of causative agent.
+	;         *C = Type of reaction, where D is drug, F is food, and O is
+	;              other.
+	;          D = 1 if Adverse Reaction has been verified
+	;              0 if Adverse Reaction has not been verified
+	;          E = 0 if this is an allergic reaction
+	;              1 if this is not an allergic reaction
+	;        **F = the mechanism of reaction in the format:
+	;              External format;Internal format
+	;              (ALLERGY;0, PHARMACOLOGIC;2, UNKNOWN;U).
+	;          G = Type of reaction.
+	;              where   D = drug
+	;                     DF = drug/food
+	;                    DFO = drug/food/other
+	;                     DO = drug/other
+	;                      F = food
+	;                     FO = food/other
+	;                      O = other
+	;          H = the mechanism of reaction in the format:
+	;              External format;Internal format
+	;              (ALLERGY;A, PHARMACOLOGIC;P, UNKNOWN;U)
+	;          I = IEN and Global root of reactant (stored in piece B above)
+	;              set equal to the GMR ALLERGY field (#1) of the PATIENT
+	;              ALLERGY file (#120.8)
+	; GMRAL(PTR TO 120.8,"S",COUNT) = S
+	;    where COUNT = number 1 to number of signs/symptoms for this
+	;                  reaction.
+	;              S = a sign/symptom for this reaction in the format:
+	;                  External format;Internal format
+	;
+	;*  NOTE: This piece will no longer be supported after 9/1/97,
+	;         Please use piece G.
+	;** NOTE: This piece will no longer be supported after 9/1/97,
+	;         Please use piece H.
+	;
+	N GMRAOTH
+	Q:'$D(DFN)  S:'$D(GMRA)#2 GMRA="0^0^111^1" K GMRAL
+DPT	;
+	;Read NKA Node in file 120.86
+	S GMRAL=$P($G(^GMR(120.86,DFN,0)),U,2)
+	;Do not set GMRAL array if patient is unassessed or NKA.
+	I GMRAL=0 Q  ;PATIENT HAS NO KNOWN ALLERGIES
+	F GMRAREC=0:0 S GMRAREC=$O(^GMR(120.8,"B",DFN,GMRAREC)) Q:GMRAREC'>0  S GMRANODE=$S($D(^GMR(120.8,GMRAREC,0)):^(0),1:"") D:GMRANODE SETAL
+	I GMRAL=1,+$O(GMRAL(0))'>0 S GMRAL=0 ;if flag is set to 1 (reactions exist), then make certain the reactions are passed in the GMRAL array
+	K GMRA,GMRANODE,GMRAOSOF,GMRAREC,GMRATCNT
+	Q
+SETAL	;
+	N %,GMRAI,GMRASIGN
+	;Q:'$P(GMRANODE,"^",12)&'$D(GMRAOSOF)  ;IF NOT SIGNED OFF MARK IT
+	Q:+$G(^GMR(120.8,GMRAREC,"ER"))&'$D(GMRAERR)  ;IF ENTERED IN ERROR QUIT
+	I GMRAL'=1 S GMRAL=1 ; PATIENT HAS ALLERGIES
+	S GMRAI=0 ; BEGIN CHECK FOR ADR/ALL CRITERIA
+	I $P(GMRA,"^",4),$P(GMRANODE,"^",6)="h" Q  ;QUIT IF HISTORICAL EXCLUDED  **LOCAL
+	I '$P(GMRA,"^") S GMRAI=1
+	E  I $P(GMRA,"^")=1 S:$F("AU",$P(GMRANODE,"^",14))>1 GMRAI=1
+	E  S:$F("P",$P(GMRANODE,"^",14))>1 GMRAI=1
+	Q:'GMRAI  ; QUIT IF ADR/ALL CRITERIA NOT MET
+	Q:2-$P(GMRA,"^",2)=(1-$P(GMRANODE,"^",16))  ;QUIT IF VER/NON VER CRITERIA NOT MET
+	S GMRAI=0 ; BEGIN CHECK FOR ALLERGY TYPE CRITERIA
+	F %=1:1:3 I $E($P(GMRA,"^",3),%),$P(GMRANODE,"^",20)[$E("OFD",%) S GMRAI=1 Q
+	Q:'GMRAI  ; QUIT IF ALLERGY TYPE CRITERIA NOT MET
+	D PASS(GMRAREC,.GMRAL)
+	Q
+PASS(GMRAREC,GMRAL)	; Data filer
+	; This subroutine will store all the patient date for a reaction is an
+	; array.
+	; Input:
+	;     GMRAREC = The IEN for the entry in 120.8
+	;Output:
+	;     GMRAL(GMRAREC) the array entry for the record
+	;
+	N GMRANODE
+	S GMRANODE=$G(^GMR(120.8,GMRAREC,0)) Q:GMRANODE=""
+	S %=$P(GMRANODE,"^",14)
+	S GMRAL(GMRAREC)=$P(GMRANODE,"^",1,2)_"^"_$E($P(GMRANODE,"^",20))_"^"_+$P(GMRANODE,"^",16)_"^"_$S(%="A"!(%="U"):0,1:1)
+	S GMRAL(GMRAREC)=GMRAL(GMRAREC)_"^"_$S(%="A":"ALLERGY;0",%="P":"PHARMACOLOGIC;2",%="U":"UNKNOWN;U",1:"")_"^"_$P(GMRANODE,"^",20)_"^"_$S(%="A":"ALLERGY;A",%="P":"PHARMACOLOGIC;P",%="U":"UNKNOWN;U",1:"")
+	S GMRAL(GMRAREC)=GMRAL(GMRAREC)_"^"_$P(GMRANODE,"^",3)
+	Q:'$O(^GMR(120.8,GMRAREC,10,0))  ;QUIT IF NO SIGNS/SYMPTOMS
+	S:'$D(GMRAOTH) GMRAOTH=$O(^GMRD(120.83,"B","OTHER REACTION",0))
+	S GMRAX=0,GMRAY=1 F  S GMRAX=$O(^GMR(120.8,GMRAREC,10,GMRAX)) Q:GMRAX<1  D  I GMRAZ'="" S GMRAL(GMRAREC,"S",GMRAY)=GMRAZ(1),GMRAY=GMRAY+1
+	.S GMRAZ=$G(^GMR(120.8,GMRAREC,10,GMRAX,0))
+	.S GMRAZ(1)=$S(+GMRAZ'=GMRAOTH:$P($G(^GMRD(120.83,+GMRAZ,0)),U)_";"_+GMRAZ,1:$P(GMRAZ,U,2)_";"_+GMRAZ)
+	.Q
+	K GMRAX,GMRAY,GMRAZ
+	Q
Index: /qrda/C0Q/trunk/p/C0QGMTSA.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QGMTSA.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QGMTSA.m	(revision 1223)
@@ -0,0 +1,26 @@
+C0QGMTSA	; SLC/DLT,KER - Brief Adverse Reaction/Allergy ; 02/27/2002
+	;;2.7;Health Summary;**28,49**;Oct 20, 1995;Build 13
+	;                 
+	; External References
+	;   DBIA 10096  ^%ZOSF("TEST"
+	;   DBIA 10099  EN1^GMRADPT **LOCAL NOW EN1^C0QGMRAD
+	;                   
+ALLRG	; Allergies
+	N I,Z,X,SEQ,GMTSA,ALLRG K GMTSA S (SEQ,ALLRG)=0 S X="C0QGMRAD" X ^%ZOSF("TEST")
+	I $T D  Q:$D(GMTSQIT)
+	. D GETALLRG I ALLRG D
+	. . D CKP^GMTSUP Q:$D(GMTSQIT)  W ?3,"Allergy/Reaction: " D ALLRGP
+	Q
+ALLRGP	; Allergy Print
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W ?21 S X=0
+	F I=0:0 S I=$O(GMTSA(I)) Q:I=""  D  Q:$D(GMTSQIT)
+	. S X=X+1 W:X>1 ", " W:(77)'>($X+$L(GMTSA(I))) !
+	. D CKP^GMTSUP Q:$D(GMTSQIT)  W GMTSA(I)
+	Q:$D(GMTSQIT)  D CKP^GMTSUP Q:$D(GMTSQIT)  W ! Q
+GETALLRG	; Get Allergies
+	N GMI,GMJ,GMRAL D EN1^C0QGMRAD I GMRAL="" S ALLRG=0 Q
+	I GMRAL="0" S ALLRG=1,GMTSA(1)="No Known Allergies" Q
+	S ALLRG=1,GMI=0 F  S GMI=$O(GMRAL(GMI)) Q:GMI'>0  D
+	. S GMTSA(GMI)=$P(GMRAL(GMI),U,2)
+	. S GMJ=0 F  S GMJ=$O(GMTSA(GMJ)) Q:GMJ'>0  I GMI'=GMJ,(GMTSA(GMI)=$G(GMTSA(GMJ))) K GMTSA(GMI) Q
+	Q
Index: /qrda/C0Q/trunk/p/C0QGMTSG.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QGMTSG.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QGMTSG.m	(revision 1223)
@@ -0,0 +1,101 @@
+C0QGMTSG	; SLC/DLT,KER - Allergies ; 01/06/2003
+	;;2.7;Health Summary;**9,28,49,58**;Oct 20, 1995;Build 13
+	;                 
+	; External References
+	;   DBIA 10096  ^%ZOSF("TEST"
+	;   DBIA 10035  ^DPT(
+	;   DBIA   905  ^GMR(120.8
+	;   DBIA  2056  $$GET1^DIQ (file #120.86 and #200)
+	;   DBIA 10011  ^DIWP
+	;   DBIA 10099  EN1^GMRADPT  **LOCAL changed to C0QGMRAD
+	;   DBIA 10060  ^VA(200,
+	;   DBIA  3449  ^GMR(120.86,
+	;                   
+ALLRG	; Allergies
+	N X,GMTSALAS,GMTSALAD,GMTSALAW,GMTSALAT,GMTSAV,GMTSAFN,GMRAL,GMTSAL
+	N GMTSALNM,GMTSCNT,GMTSEACT,GMTSLN,GMTSMECH,GMTSPRT,GMTSTY,CC,C,KK
+	N ALLRG,TITLE,JJ K GMTSA S (SEQ,ALLRG)=0,TITLE="ALLERGY/ADVERSE REACTION (AR)"
+	S X="C0QGMRAD" X ^%ZOSF("TEST")
+	I $T D  Q:$D(GMTSQIT)
+	. D GETALLRG D:ALLRG TITLE,ALLRGP D:'ALLRG&($L($G(GMTSALAS))) TITLE,NKA
+	I 'ALLRG,'$L($G(GMTSALAS)) D
+	. I $D(GMTSPNF)&('ALLRG) D CKP^GMTSUP Q:$D(GMTSQIT)  W "Unknown, please evaluate",!
+	K ALL,CC,CCC,CD,DIWF,DIWL,DIWR,GMTSALF,GMTSALNM,GMTSNODE,GMTSPRT,I,II,JJ,KK,L,M,MX,N,Z,X,SEQ,GMTSA,ALLRG,TITLE,GMRA,GMRAL,GMTSEACT,GMTSMECH,GMTSTY,GMTSPFN,GMTSAL,GMTSCNT,GMTSLN,ODT
+	Q
+ALLRGP	; Allergy Print
+	S II="" F  S II=$O(GMTSAL(II)) Q:II']""  I $O(GMTSAL(II,""))]"" D
+	. D CKP^GMTSUP Q:$D(GMTSQIT)  W !?2,$S(II="D":"Drug:",II="DF":"Drug/Food:",II="DFO":"Drug/Food/Other:",II="DO":"Drug/Other:",II="F":"Food:",II="FO":"Food/Other:",II="O":"Other:",1:II_":")
+	. S JJ="" F  S JJ=$O(GMTSAL(II,JJ)) Q:JJ=""  D
+	.. N WKK S KK=""  F  S KK=$O(GMTSAL(II,JJ,KK)) Q:KK=""  D
+	... S L=0 F  S L=$O(GMTSAL(II,JJ,KK,L)) Q:'L  D CKP^GMTSUP Q:$D(GMTSQIT)  D AUTOV W !?5,JJ_": " S:$L(KK)>30 WKK=KK,WKK=$$WRAP^GMTSORC(WKK,30) W ?24,$S($L(KK)>30:$P(WKK,"|"),1:KK) D
+	.... I GMTSAV=1 W " (AV"
+	.... E  W $S($P(GMTSAL(II,JJ,KK,L),U,5)=1:" (V",$P(GMTSAL(II,JJ,KK,L),U,5)=0:" (NV",1:"")
+	.... W $S($P($G(^GMR(120.8,GMTSALNM,0)),U,6)="h":"/Historical)",$P($G(^(0)),U,6)="o":"/Observed)",1:")")
+	.... I $L($P($G(WKK),"|",2)) D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?24,$P(WKK,"|",2)
+	.... S (M,MX,ALL)=0 F  S M=$O(GMTSAL(II,JJ,KK,L,"S",M)) Q:M=""  D  Q:$D(GMTSQIT)
+	..... I ALL=0 D CKP^GMTSUP Q:$D(GMTSQIT)  W !?27
+	..... S MX=MX+1
+	..... W:MX>1 ", "
+	..... S N=$P(GMTSAL(II,JJ,KK,L,"S",M),";")
+	..... S ALL=1 I (74)'>($X+$L(N)) D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?27,N Q
+	..... S ALL=1 W N
+	.... D SIGBLK($P(GMTSAFN,U,5))
+	.... D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?24,"Date/Time:  " S ODT=$P(GMTSAFN,U,4) S X=ODT D REGDTM4^GMTSU W X,!
+	....S CC="" F  S CC=$O(^GMR(120.8,GMTSALNM,26,"B",CC)) Q:CC=""  D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?24,"Comments at: " S X=CC D REGDTM4^GMTSU S CD=X S CCC=0 F  S CCC=$O(^GMR(120.8,GMTSALNM,26,"B",CC,CCC)) Q:'CCC  D TEXT
+	Q
+NKA	; No known allergies
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAS))!($L($G(GMTSALAD))) !
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAS)) ?22,$G(GMTSALAS),!
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAS))!($L($G(GMTSALAD)))!($L($G(GMTSALAW))) ?24,"Assessment date:   ",$G(GMTSALAD),!
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAW)) ?28,"Assessed by:   ",GMTSALAW,!
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L($G(GMTSALAW))&($L($G(GMTSALAT))) ?34,"Title:   ",GMTSALAT,!
+	Q
+GETALLRG	; Get Allergies
+	S GMRA="0^0^111^1" D EN1^C0QGMRAD I GMRAL="" S ALLRG=0 Q
+	I +($G(DFN))>0,+($G(GMRAL))=0 D ALLAS S ALLRG=0 Q
+	I $D(GMRAL)>9 D
+	. S I=0 F GMTSCNT=1:1 S I=$O(GMRAL(I)) Q:'I  D
+	.. S GMTSTY=$P(GMRAL(I),U,7) Q:GMTSTY']""
+	.. S GMTSEACT=$P(GMRAL(I),U,2) Q:GMTSEACT']""
+	.. S GMTSMECH=$P($P(GMRAL(I),U,8),";")
+	.. S:GMTSMECH']"" GMTSMECH="UNKNOWN"
+	.. S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT)=I_"^"_GMRAL(I)
+	.. S JJ=0 F  S JJ=$O(GMRAL(I,"S",JJ)) Q:'JJ  S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT,"S",JJ)=GMRAL(I,"S",JJ)
+	.. S ALLRG=1
+	Q
+ALLAS	; Allergy Assessment
+	N X,GMTSALG1,GMTSALG2,GMTSALG3,GMTSAU S (GMTSALAS,GMTSALAD,GMTSALAW)="" S GMTSALAS="No known allergies"
+	S GMTSALAD=$$GET1^DIQ(120.86,+($G(DFN)),3,"I",,"GMTSALG2") S:$D(GMTSALG2) GMTSALAD="" S:+GMTSALAD=0 GMTSALAD=""
+	I +GMTSALAD>0 S X=GMTSALAD D REGDT4^GMTSU S GMTSALAD=X
+	S GMTSAU=$$GET1^DIQ(120.86,+($G(DFN)),2,"I")
+	S GMTSALAW=$$GET1^DIQ(200,(+GMTSAU_","),.01,"E",,"GMTSALG3")
+	S GMTSALAT=$$GET1^DIQ(200,(+GMTSAU_","),20.3)
+	S:$D(GMTSALG3) (GMTSALAW,GMTSALAT)=""
+	Q
+AUTOV	; Autoverify
+	S GMTSAV=0,GMTSALNM=$P(GMTSAL(II,JJ,KK,L),U),GMTSAFN=$G(^GMR(120.8,GMTSALNM,0))
+	I $P(GMTSAFN,U,18)="",$P(GMTSAFN,U,16)=1 S GMTSAV=1
+	Q
+TITLE	; Print title
+	D CKP^GMTSUP Q:$D(GMTSQIT)
+	I $D(GMTSPNF) W ?21,TITLE,!
+	E  W ?21,"Title: ",TITLE,!
+	Q
+TEXT	; Setup for print of allergy comments
+	W ?31,CD D CKP^GMTSUP Q:$D(GMTSQIT)
+	K ^UTILITY($J,"W") S GMTSLN=0 F  S GMTSLN=$O(^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN)) Q:'GMTSLN  S GMTSPRT=^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN,0) D FORMAT
+	I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",DIWL) D LINE Q:$D(GMTSQIT)
+	K ^UTILITY($J,"W")
+	Q:'GMTSLN
+	W ! Q
+FORMAT	; Formats each line
+	S DIWL=3,DIWR=80,DIWF="C58",X=GMTSPRT D ^DIWP
+	Q
+LINE	; Writes formatted lines of text
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W !,?24,^UTILITY($J,"W",DIWL,GMTSLN,0)
+	Q
+SIGBLK(GMTSALF)	; Signature block
+	Q:+GMTSALF'>0  N GMTSSB,GMTSST,GMTSSN S GMTSSB=$$GET1^DIQ(200,(+GMTSALF_","),20.2),GMTSST=$$GET1^DIQ(200,(+GMTSALF_","),20.3),GMTSSN=$$GET1^DIQ(200,(+GMTSALF_","),.01)
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W !!,?24,"Originator: ",$S(GMTSSB'="":GMTSSB,1:GMTSSN)
+	D CKP^GMTSUP Q:$D(GMTSQIT)  W:$L(GMTSST) !,?24,"Title:      ",GMTSST
+	Q
Index: /qrda/C0Q/trunk/p/C0QIMMUN.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QIMMUN.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QIMMUN.m	(revision 1223)
@@ -0,0 +1,52 @@
+C0QIMMUN	;Prep Immunization Order data for HL7 Message creation ;
+	;;0.1;C0Q;nopatch;noreleasedate;Build 13
+	;  ^XTMP("C0QIMMUN",0)=purge date^create date
+	;  ^XTMP("C0QIMMUN",order_date,order#,item_name)=item_value
+	;  ^XTMP("C0QIMMUN","LASTORDR")=last order processed
+FIND	; Find the next set of immunization orders
+	N X1,X2,X,%,%DT,%H,%T,NOW,ORDER,LASTORDR,SUBSC,DIR
+	S LASTORDR=+$G(^XTMP("C0QIMMUN","LASTORDR"))
+	W !,"The ""Last Order"" from which to begin checking for Immunization orders is: ",LASTORDR
+	S DIR("A")="Do you want to reset that value"
+	S DIR(0)="Y",DIR("B")="NO" D ^DIR D:Y=1
+	. S DIR("A")="What value shall be used?"
+	. S DIR(0)="NO",DIR("B")=LASTORDR D ^DIR
+	. W:Y'>0 !,"We'll skip reseting it then."
+	. D:Y>0
+	. . S LASTORDR=+Y
+	. . L +^XTMP("C0QIMMUN")
+	. . S X1=DT,X2=365 D C^%DTC
+	. . S ^XTMP("C0QIMMUN",0)=X_U_DT
+	. . S ^XTMP("C0QIMMUN","LASTORDR")=LASTORDR
+	. . L -^XTMP("C0QIMMUN")
+	. . Q
+	. Q
+	S DIR("A")="Ready to prep more immunization orders for HL7 messages"
+	S DIR(0)="Y",DIR("B")="YES" D ^DIR Q:Y'=1
+	L +^XTMP("C0QIMMUN")
+	I '$D(^XTMP("C0QIMMUN",0)) D
+	. S X1=DT,X2=365 D C^%DTC
+	. S ^XTMP("C0QIMMUN",0)=X_U_DT
+	. S ^XTMP("C0QIMMUN","LASTORDR")=0
+	S ORDER=^XTMP("C0QIMMUN","LASTORDR")
+	F  S ORDER=$O(^OR(100,ORDER)) Q:ORDER'>0  D
+	. S LASTORDR=ORDER
+	. D:$D(^OR(100,ORDER,4.5,"ID","ORZ HL7")) GOTONE
+	. Q
+	S ^XTMP("C0QIMMUN","LASTORDR")=LASTORDR
+	W !,"Done",!,"Last Order processed: ",LASTORDR,!
+	L -^XTMP("C0QIMMUN")
+	Q
+GOTONE	; Take the order number and move the relevant HL7 information into ^XTMP
+	S NOW=$P(^OR(100,ORDER,0),U,7)
+	S ^XTMP("C0QIMMUN",NOW,ORDER,"PATIENT")=$P(^OR(100,ORDER,0),U,2)
+	S ^XTMP("C0QIMMUN",NOW,ORDER,"LOCATION")=$P(^OR(100,ORDER,0),U,10)
+	S ^XTMP("C0QIMMUN",NOW,ORDER,"ORDEREDBY")=$P(^OR(100,ORDER,0),U,6)
+	S ENTRY=0 F  S ENTRY=$O(^OR(100,ORDER,4.5,ENTRY)) Q:ENTRY'>0  D
+	. S SUBSC=$P($G(^OR(100,ORDER,4.5,ENTRY,0)),U,4)
+	. Q:'$L(SUBSC)
+	. I SUBSC'="TIME" S ^XTMP("C0QIMMUN",NOW,ORDER,SUBSC)=^OR(100,ORDER,4.5,ENTRY,1)
+	. E  S X=^OR(100,ORDER,4.5,ENTRY,1),%DT="TS" D ^%DT S ^XTMP("C0QIMMUN",NOW,ORDER,SUBSC)=Y
+	. Q
+	S ^XTMP("C0QIMMUN",NOW,ORDER,"ORDERTEXT")=$G(^OR(100,ORDER,8,1,.1,1,0))
+	Q
Index: /qrda/C0Q/trunk/p/C0QMAIN.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QMAIN.m	(revision 1222)
+++ /qrda/C0Q/trunk/p/C0QMAIN.m	(revision 1223)
@@ -1,31 +1,31 @@
-C0QMAIN ; GPL - Quality Reporting Main Processing ;10/13/10  17:05
- ;;0.1;C0Q;nopatch;noreleasedate;
- ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
- ;General Public License See attached copy of the License.
- ;
- ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
- ;
- Q
- ;
-C0QQFN() Q 1130580001.101 ; FILE NUMBER FOR C0Q QUALITY MEASURE FILE
-C0QMFN() Q 1130580001.201 ; FILE NUMBER FOR C0Q MEASUREMENT FILE
-C0QMMFN() Q 1130580001.2011 ; FN FOR MEASURE SUBFILE
-C0QMMNFN() Q 1130580001.20111 ; FN FOR NUMERATOR SUBFILE
-C0QMMDFN() Q 1130580001.20112 ; FN FOR DENOMINATOR SUBFILE
-RLSTFN() Q 810.5 ; FN FOR REMINDER PATIENT LIST FILE
-RLSTPFN() Q 810.53 ; FN FOR REMINDER PATIENT LIST PATIENT SUBFILE
- ;
+C0QMAIN	; GPL - Quality Reporting Main Processing ;10/13/10  17:05
+	;;0.1;C0Q;nopatch;noreleasedate;Build 13
+	;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+	;General Public License See attached copy of the License.
+	;
+	;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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
+	;
+	Q
+	;
+C0QQFN()	Q 1130580001.101 ; FILE NUMBER FOR C0Q QUALITY MEASURE FILE
+C0QMFN()	Q 1130580001.201 ; FILE NUMBER FOR C0Q MEASUREMENT FILE
+C0QMMFN()	Q 1130580001.2011 ; FN FOR MEASURE SUBFILE
+C0QMMNFN()	Q 1130580001.20111 ; FN FOR NUMERATOR SUBFILE
+C0QMMDFN()	Q 1130580001.20112 ; FN FOR DENOMINATOR SUBFILE
+RLSTFN()	Q 810.5 ; FN FOR REMINDER PATIENT LIST FILE
+RLSTPFN()	Q 810.53 ; FN FOR REMINDER PATIENT LIST PATIENT SUBFILE
+C0QALFN()	Q 1130580001.311 ; FILE NUMBER FOR C0Q PATIENT LIST PATIENT SUBFILE	;
 EXPORT	  ; EXPORT ENTRY POINT FOR CCR
 	; Select a patient.
@@ -48,249 +48,304 @@
 	Q
 	;
-NBYP ; ENTRY POINT FOR COMMAND LINE BY PATIENT MEASURE LISTING
- ;
- S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
- I Y<1 Q  ; EXIT
- N MSIEN S MSIEN=+Y
- W !,"NUMERATOR PATIENT LIST",!
- N C0QPAT
- D PATS(.C0QPAT,MSIEN,"N") ; GET THE NUMERATOR PATIENT LIST
- I $D(C0QPAT) D  ; LIST RETURNED
- . ;
- Q
- ;
-DBYP ; ENTRY POINT FOR COMMAND LINE BY PATIENT MEASURE LISTING
- ;
- S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
- I Y<1 Q  ; EXIT
- N MSIEN S MSIEN=+Y
- N C0QPAT
- W !,"DENOMINATOR PATIENT LIST",!
- D PATS(.C0QPAT,MSIEN,"D") ; GET THE NUMERATOR PATIENT LIST
- I $D(C0QPAT) D  ; LIST RETURNED
- . ;
- . ;
- Q
- ;
-ENEXP ; EXTERNAL MENU ENTRY POINT FOR EXP
- ;
- S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
- I Y<1 Q  ; EXIT
- N MSIEN S MSIEN=+Y
- D EXP(MSIEN)
- Q
- ; 
-EXP(MSET,NOEX) ; EXPORT ALL PATIENTS FOR MEASURE SET IEN MSET
- ; ALSO, WRITE OUT THE BY PATIENT MEASURE TEXT FILE
- ; IF NOEX=1, THEN ONLY THE MEASURE TEXT FILE GETS WRITTEN, NO EXPORTS ARE 
- ; DONE
- I '$D(NOEX) S NOEX=0
- N ZQI,ZARY,ZFN,ODIR
- S ZQI=""
- D PATS(.ZARY,MSET,"D",1)
- S ZFN="MEASURES-BY-PATIENT.txt"
- S ODIR=^TMP("C0CCCR","ODIR") ; OUTPUT DIRECTORY
- S GARY=$NA(^TMP("C0Q",$J))
- K @GARY
- M @GARY=ZARY
- S GARY1=$NA(@GARY@(1))
- N ZY
- S ZY=$$OUTPUT^C0CXPATH(GARY1,ZFN,ODIR)
- W !,ZY
- I NOEX=1 Q  ; DO NOT EXPORT
- F  S ZQI=$O(ZARY(ZQI)) Q:ZQI=""  D  ; FOR EACH PATIENT
- . D XPAT^C0CCCR(+ZARY(ZQI)) ; 
- Q
- ;
-PATS(ZRTN,MSIEN,NORD,QT) ; BUILDS A LIST OF PATIENTS AND THEIR MEASURES
- ; FOR MEASURE SET MSET. NORD="N" (DEFAULT) MEANS NUMERATOR PATIENTS
- ; NORD="D" MEANS DENOMINATOR PATIENTS 
- ; QT=1 MEANS QUIET
- I $G(QT)'=1 S QT=0
- N ZI,ZJ,ZK,ZIDX,ZN,ZM
- S ZN=0 ; COUNT OF PATIENTS
- S ZI=""
- ; GOING TO USE THE NUMERATOR BY PATIENT INDEX
- I '$D(NORD) S NORD="N"
- I '((NORD="N")!(NORD="D")) S NORD="N"
- I NORD="N" S ZIDX=$NA(^C0Q(201,"ANBYP"))
- E  S ZIDX=$NA(^C0Q(201,"ADBYP"))
- F  S ZI=$O(@ZIDX@(ZI)) Q:ZI=""  D  ; FOR EACH PATIENT
- . I $O(@ZIDX@(ZI,MSIEN,""))'="" D  ; IF PATIENT IS IN THIS SET
- . . I 'QT W !,$$GET1^DIQ(2,ZI_",",.01) ;PATIENT NAME
- . . S ZN=ZN+1 ; INCREMENT PATIENT COUNT
- . . S ZRTN(ZN)=ZI
- . E  Q  ; NEXT PATIENT
- . S (ZJ,ZK)=""
- . F  S ZJ=$O(@ZIDX@(ZI,MSIEN,ZJ)) Q:ZJ=""  D  ; FOR EACH MEASURE
- . . ;S ZL=$O(@ZIDX@(ZI,MSIEN,ZJ,"")) ; MEASURE IS FOURTH
- . . S ZK=""
- . . S ZK=$$GET1^DIQ($$C0QMMFN,ZJ_","_MSIEN_",",.01,"I")
- . . ;W !,"ZK:",ZK," ZJ:",ZJ," ZI",ZI,!
- . . S ZM=$$GET1^DIQ($$C0QQFN,ZK_",",.01) ; MEASURE NAME
- . . I 'QT W " ",ZM
- . . S ZRTN(ZN)=ZRTN(ZN)_" "_ZM
- Q
- ;
-EN ; ENTRY POINT FOR COMMAND LINE AND MENU ACCESS TO C0QRPC
- ;
- S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
- I Y<1 Q  ; EXIT
- N MSIEN S MSIEN=+Y
- D C0QRPC(.G,MSIEN)
- Q
- ;
-EN2 ; SUMMARY ENTRY POINT FOR COMMAND LINE AND MENU ACCESS TO C0QRPC
- ;
- S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
- I Y<1 Q  ; EXIT
- N MSIEN S MSIEN=+Y
- S C0QSUM=1
- D C0QRPC(.G,MSIEN)
- Q
- ;
-C0QRPC(RTN,MSET,FMT,NOPURGE) ; RPC FORMAT 
- ; MSET IS THE NAME OR IEN OF THE MEASURE SET
- ; RTN IS THE RETURN ARRAY OF THE RESULTS PASSED BY REFERENCE
- ; FMT IS THE FORMAT OF THE OUTPUT - "ARRAY" OR "HTML" OR "XML"
- ;  NOTE: ARRAY IS DEFAULT AND THE OTHERS ARE NOT IMPLEMENTED YET
- ; IF NOPURGE IS 1, PATIENT LISTS WILL NOT BE DELETED BEFORE ADDING
- ; IF NOPURGE IS 0 OR OMITTED, PATIENT LISTS WILL BE DELETED THEN ADDED
- W !,"LOOKING FOR MEASURE SET ",MSET,!
- N ZI S ZI=""
- N C0QM ; FOR HOLDING THE MEASURES IN THE SET
- D LIST^DIC($$C0QMMFN,","_MSET_",",".01I") ; GET ALL THE MEASURES
- D DELIST("C0QM")
- N ZII S ZII=""
- F  S ZII=$O(C0QM(ZII)) Q:ZII=""  D  ; FOR EACH MEASURE
- . D CLEARMEA(MSET,ZII) ; FIRST CLEAR OUT THE MEASURE
- K C0QM
- D CLEAN^DILF
- D LIST^DIC($$C0QMMFN,","_MSET_",",".01I") ; GET ALL THE MEASURES AGAIN
- D DELIST("C0QM")
- F  S ZII=$O(C0QM(ZII)) Q:ZII=""  D  ; FOR EACH MEASURE
- . S ZI=$P(C0QM(ZII),U,1) ; IEN OF THE MEASURE IN THE C0Q QUALITY MEAS FILE
- . ;W $$GET1^DIQ($$C0QQFN,ZI_",","DISPLAY NAME"),!
- . ;N C0QNL,C0QDL ;NUMERATOR AND DENOMINATOR LIST POINTERS
- . W !,"MEASURE: ",$$GET1^DIQ($$C0QQFN,ZI_",",.01),! ; PRINT THE MEASURE NAME
- . ; FOLLOW THE POINTERS TO THE C0Q QUALITYM MEASURE FILE AND GET LIST PTRS
- . S C0QNL=$$GET1^DIQ($$C0QQFN,ZI_",",1,"I") ; NUMERATOR POINTER
- . S C0QDL=$$GET1^DIQ($$C0QQFN,ZI_",",2,"I") ; DENOMINATOR POINTER
- . ; NOW FOLLOW THE LIST POINTERS TO THE REMINDER PATIENT LIST FILE
- . W "NUMERATOR: ",$$GET1^DIQ($$RLSTFN,C0QNL_",","NAME"),!
- . ; FIRST PROCESS THE NUMERATOR
- . K ^TMP("DILIST",$J)
- . D LIST^DIC($$RLSTPFN,","_C0QNL_",",".01I") ; GET THE LIST OF PATIENTS
- . ;D DELIST("G") ;
- . ;I $D(G) ZWR G
- . K C0QNUMP
- . S NCNT=$O(^TMP("DILIST",$J,"ID",""),-1) ; NUMERATOR COUNT
- . N ZJ S ZJ=""
- . F  S ZJ=$O(^TMP("DILIST",$J,"ID",ZJ)) Q:ZJ=""  D  ;
- . . S ZDFN=^TMP("DILIST",$J,"ID",ZJ,.01)
- . . S C0QNUMP("N",ZJ,ZDFN)=""
- . I '$G(C0QSUM) ZWR ^TMP("DILIST",$J,1,*) ; LIST THE PATIENT NAMES
- . D ADDPATS(MSET,ZII,"C0QNUMP")
- . ; NEXT PROCESS THE DENOMINATOR
- . W "DENOMINATOR: ",$$GET1^DIQ($$RLSTFN,C0QDL_",","NAME"),!
- . K ^TMP("DILIST",$J)
- . D LIST^DIC($$RLSTPFN,","_C0QDL_",",".01I") ; GET THE LIST OF PATIENTS
- . ;D DELIST("G")
- . ;I $D(G) ZWR G
- . ;S ZJ=""
- . S DCNT=$O(^TMP("DILIST",$J,"ID",""),-1) ; DENOMONIATOR COUNT
- . K C0QDEMP
- . F  S ZJ=$O(^TMP("DILIST",$J,"ID",ZJ)) Q:ZJ=""  D  ;
- . . S ZDFN=^TMP("DILIST",$J,"ID",ZJ,.01)
- . . S C0QDEMP("D",ZJ,ZDFN)=""
- . D ADDPATS(MSET,ZII,"C0QDEMP")
- . I $G(C0QSUM)'=1 ZWR ^TMP("DILIST",$J,1,*) ; LIST THE PATIENT NAMES
- . E  D  ;
- . . W "NUM CNT: ",NCNT
- . . W "  DEN CNT: ",DCNT,!
- Q
- ;
-CLEARMEA(MSET,MEAS) ; DELETE AND THEN RECREATE AS EMPTY THE
- ; MEASURE MEAS IN MEASURE SET IEN MSET
- ;
- N C0QFDA,MFN,MEASURE
- S MFN=$$C0QMMFN() ; FILE NUMBER FOR MEASURE SUBFILE
- D CLEAN^DILF
- S MEASURE=$$GET1^DIQ(MFN,MEAS_","_MSET_",",.01,"I") ;  MEASURE POINTER
- D CLEAN^DILF
- K ZERR
- S C0QFDA(MFN,MEAS_","_MSET_",",.01)="@" ; GET READY TO DELETE THE MEASURE
- D FILE^DIE(,"C0QFDA","ZERR") ; KILL THE SUBFILE
- I $D(ZERR) D ;
- . W "ERROR",!
- . ZWR ZERR
- . B
- K C0QFDA
- S C0QFDA(MFN,"+1,"_MSET_",",.01)=MEASURE ; GET READY TO RECREATE THE SUBFILE
- D UPDIE ; CREATE THE SUBFILE
- Q
- ;
-ADDPATS(MSET,MEAS,PATS) ;ADD PATIENTS TO NUMERATOR AND DENOMINATOR
- ; OF MEASURE SET IEN MSET MEASURE IEN MEAS
- ; PATS IS OF THE FORM @PATS@("N",X,DFN)="" AND @PATS@("D",X,DFN)=""
- ; WHERE N IS FOR NUMERATOR AND D IS FOR DENOMINATOR AND X 1..N
- ; IF PATIENTS ARE ALREADY THERE, THEY WILL NOT BE ADDED AGAIN
- N C0QI,C0QJ
- N C0QFDA
- S C0QI=""
- F  S C0QI=$O(@PATS@("N",C0QI)) Q:C0QI=""  D  ; FOR EACH NUMERATOR PATIENT
- . S C0QFDA($$C0QMMNFN,"?+"_C0QI_","_MEAS_","_MSET_",",.01)=$O(@PATS@("N",C0QI,""))
- ;W "ADDING NUMERATOR",!
- ;I $D(C0QFDA) ZWR C0QFDA
- I $D(C0QFDA) D UPDIE
- K C0QFDA
- S C0QI=""
- F  S C0QI=$O(@PATS@("D",C0QI)) Q:C0QI=""  D  ; FOR EACH NUMERATOR PATIENT
- . S C0QFDA($$C0QMMDFN,"?+"_C0QI_","_MEAS_","_MSET_",",.01)=$O(@PATS@("D",C0QI,""))
- ;W "ADDING DENOMINATOR",!
- ;I $D(C0QFDA) ZWR C0QFDA
- I $D(C0QFDA) D UPDIE
- Q
- ;
-DELIST(RTN) ; DECODES ^TMP("DILIST",$J) INTO
- ; @RTN@(IEN)=INTERNAL VALUE^EXTERNAL VALUE
- N ZI,IV,EV,ZDI,ZIEN
- S ZI=""
- S ZDI=$NA(^TMP("DILIST",$J))
- K @RTN
- F  S ZI=$O(@ZDI@(1,ZI)) Q:ZI=""  D  ;
- . S EV=@ZDI@(1,ZI) ;EXTERNAL VALUE
- . S IV=$G(@ZDI@("ID",ZI,.01)) ; INTERNAL VALUE
- . S ZIEN=@ZDI@(2,ZI) ; IEN
- . S @RTN@(ZIEN)=IV_"^"_EV
- Q
- ;
-DELPATS(MSET,MEAS,NDEL) ; DELETE PATIENTS FROM NUMERATOR AND DENOMINATOR
- ; FOR A MEASURE (ONLY AFFECTS THE C0Q MEASURES FILE)
- ; MSET IS THE IEN OF THE MEASURE SET
- ; MEAS IS THE IEN OF THE MEASURE
- ; NDEL IS A LIST OF PATIENTS TO NOT DELETE (NOT IMPLEMENTED YET)
- ;  IN THE FORM @NDEL@("N",IEN,DFN)="" FOR NUMERATOR PATIENTS
- ;  AND @NDEL@("D",IEN,DFN)="" FOR DENOMINATOR PATIENTS WHERE IEN IS 
- ;  THE IEN OF THE PATIENT RECORD IN THE SUBFILE
- ;  THIS FEATURE WILL ALLOW EFFICIENCIES FOR LONG PATIENT LISTS
- ;  IN THAT PATIENTS THAT ARE GOING TO BE ADDED ARE NOT FIRST DELETED
- N C0QI,C0QJ
- D LIST^DIC($$C0QMMFN,","_MSET_",")
- K C0QFDA
- ZWR ^TMP("DILIST",$J,*)
- ZWR ^TMP("DIERR",$J,*)
- D 
- Q
- ;
+NBYP	; ENTRY POINT FOR COMMAND LINE BY PATIENT MEASURE LISTING
+	;
+	S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
+	I Y<1 Q  ; EXIT
+	N MSIEN S MSIEN=+Y
+	W !,"NUMERATOR PATIENT LIST",!
+	N C0QPAT
+	D PATS(.C0QPAT,MSIEN,"N") ; GET THE NUMERATOR PATIENT LIST
+	I $D(C0QPAT) D  ; LIST RETURNED
+	. ;
+	Q
+	;
+DBYP	; ENTRY POINT FOR COMMAND LINE BY PATIENT MEASURE LISTING
+	;
+	S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
+	I Y<1 Q  ; EXIT
+	N MSIEN S MSIEN=+Y
+	N C0QPAT
+	W !,"DENOMINATOR PATIENT LIST",!
+	D PATS(.C0QPAT,MSIEN,"D") ; GET THE NUMERATOR PATIENT LIST
+	I $D(C0QPAT) D  ; LIST RETURNED
+	. ;
+	. ;
+	Q
+	;
+ENEXP	; EXTERNAL MENU ENTRY POINT FOR EXP
+	;
+	S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
+	I Y<1 Q  ; EXIT
+	N MSIEN S MSIEN=+Y
+	D EXP(MSIEN)
+	Q
+	; 
+EXP(MSET,NOEX)	; EXPORT ALL PATIENTS FOR MEASURE SET IEN MSET
+	; ALSO, WRITE OUT THE BY PATIENT MEASURE TEXT FILE
+	; IF NOEX=1, THEN ONLY THE MEASURE TEXT FILE GETS WRITTEN, NO EXPORTS ARE 
+	; DONE
+	I '$D(NOEX) S NOEX=0
+	N ZQI,ZARY,ZFN,ODIR
+	S ZQI=""
+	D PATS(.ZARY,MSET,"D",1)
+	S ZFN="MEASURES-BY-PATIENT.txt"
+	S ODIR=^TMP("C0CCCR","ODIR") ; OUTPUT DIRECTORY
+	S GARY=$NA(^TMP("C0Q",$J))
+	K @GARY
+	M @GARY=ZARY
+	S GARY1=$NA(@GARY@(1))
+	N ZY
+	S ZY=$$OUTPUT^C0CXPATH(GARY1,ZFN,ODIR)
+	W !,ZY
+	I NOEX=1 Q  ; DO NOT EXPORT
+	F  S ZQI=$O(ZARY(ZQI)) Q:ZQI=""  D  ; FOR EACH PATIENT
+	. D XPAT^C0CCCR(+ZARY(ZQI)) ; 
+	Q
+	;
+PATS(ZRTN,MSIEN,NORD,QT)	; BUILDS A LIST OF PATIENTS AND THEIR MEASURES
+	; FOR MEASURE SET MSET. NORD="N" (DEFAULT) MEANS NUMERATOR PATIENTS
+	; NORD="D" MEANS DENOMINATOR PATIENTS 
+	; QT=1 MEANS QUIET
+	I $G(QT)'=1 S QT=0
+	N ZI,ZJ,ZK,ZIDX,ZN,ZM
+	S ZN=0 ; COUNT OF PATIENTS
+	S ZI=""
+	; GOING TO USE THE NUMERATOR BY PATIENT INDEX
+	I '$D(NORD) S NORD="N"
+	I '((NORD="N")!(NORD="D")) S NORD="N"
+	I NORD="N" S ZIDX=$NA(^C0Q(201,"ANBYP"))
+	E  S ZIDX=$NA(^C0Q(201,"ADBYP"))
+	F  S ZI=$O(@ZIDX@(ZI)) Q:ZI=""  D  ; FOR EACH PATIENT
+	. I $O(@ZIDX@(ZI,MSIEN,""))'="" D  ; IF PATIENT IS IN THIS SET
+	. . I 'QT W !,$$GET1^DIQ(2,ZI_",",.01) ;PATIENT NAME
+	. . S ZN=ZN+1 ; INCREMENT PATIENT COUNT
+	. . S ZRTN(ZN)=ZI
+	. E  Q  ; NEXT PATIENT
+	. S (ZJ,ZK)=""
+	. F  S ZJ=$O(@ZIDX@(ZI,MSIEN,ZJ)) Q:ZJ=""  D  ; FOR EACH MEASURE
+	. . ;S ZL=$O(@ZIDX@(ZI,MSIEN,ZJ,"")) ; MEASURE IS FOURTH
+	. . S ZK=""
+	. . S ZK=$$GET1^DIQ($$C0QMMFN,ZJ_","_MSIEN_",",.01,"I")
+	. . ;W !,"ZK:",ZK," ZJ:",ZJ," ZI",ZI,!
+	. . S ZM=$$GET1^DIQ($$C0QQFN,ZK_",",.01) ; MEASURE NAME
+	. . I 'QT W " ",ZM
+	. . S ZRTN(ZN)=ZRTN(ZN)_" "_ZM
+	Q
+	;
+EN	; ENTRY POINT FOR COMMAND LINE AND MENU ACCESS TO C0QRPC
+	;
+	S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
+	I Y<1 Q  ; EXIT
+	N MSIEN S MSIEN=+Y
+	D C0QRPC(.G,MSIEN)
+	Q
+	;
+EN2	; SUMMARY ENTRY POINT FOR COMMAND LINE AND MENU ACCESS TO C0QRPC
+	;
+	S DIC=$$C0QMFN,DIC(0)="AEMQ" D ^DIC
+	I Y<1 Q  ; EXIT
+	N MSIEN S MSIEN=+Y
+	S C0QSUM=1
+	D C0QRPC(.G,MSIEN)
+	; iterate over the measures
+	S MEASURE=0
+	F  S MEASURE=$O(^C0Q(201,MSIEN,5,MEASURE)) Q:MEASURE'>0  D
+	. S NUMER=0,DENOM=0
+	. ; now count the numerator patients
+	. S P=0 F  S P=$O(^C0Q(201,MSIEN,5,MEASURE,1,P)) Q:P'>0  S NUMER=NUMER+1
+	. S $P(^C0Q(201,MSIEN,5,MEASURE,2),U)=NUMER
+	. ; and count the denominator patients
+	. S P=0 F  S P=$O(^C0Q(201,MSIEN,5,MEASURE,3,P)) Q:P'>0  S DENOM=DENOM+1
+	. Q:DENOM=0
+	. ; and stuff the values
+	. S $P(^C0Q(201,MSIEN,5,MEASURE,4),U,1,2)=DENOM_U_$J(100*NUMER/DENOM,0,0)
+	. Q
+	Q
+	;
+C0QRPC(RTN,MSET,FMT,NOPURGE)	; RPC FORMAT 
+	; MSET IS THE NAME OR IEN OF THE MEASURE SET
+	; RTN IS THE RETURN ARRAY OF THE RESULTS PASSED BY REFERENCE
+	; FMT IS THE FORMAT OF THE OUTPUT - "ARRAY" OR "HTML" OR "XML"
+	;  NOTE: ARRAY IS DEFAULT AND THE OTHERS ARE NOT IMPLEMENTED YET
+	; IF NOPURGE IS 1, PATIENT LISTS WILL NOT BE DELETED BEFORE ADDING
+	; IF NOPURGE IS 0 OR OMITTED, PATIENT LISTS WILL BE DELETED THEN ADDED
+	;W !,"LOOKING FOR MEASURE SET ",MSET,!
+	N ZI S ZI=""
+	N C0QM ; FOR HOLDING THE MEASURES IN THE SET
+	D LIST^DIC($$C0QMMFN,","_MSET_",",".01I") ; GET ALL THE MEASURES
+	D DELIST("C0QM")
+	N ZII S ZII=""
+	F  S ZII=$O(C0QM(ZII)) Q:ZII=""  D  ; FOR EACH MEASURE
+	. D CLEARMEA(MSET,ZII) ; FIRST CLEAR OUT THE MEASURE
+	K C0QM
+	D CLEAN^DILF
+	D LIST^DIC($$C0QMMFN,","_MSET_",",".01I") ; GET ALL THE MEASURES AGAIN
+	D DELIST("C0QM")
+	F  S ZII=$O(C0QM(ZII)) Q:ZII=""  D  ; FOR EACH MEASURE
+	. S ZI=$P(C0QM(ZII),U,1) ; IEN OF THE MEASURE IN THE C0Q QUALITY MEAS FILE
+	. ;W $$GET1^DIQ($$C0QQFN,ZI_",","DISPLAY NAME"),!
+	. ;N C0QNL,C0QDL ;NUMERATOR AND DENOMINATOR LIST POINTERS
+	. ;W !,"MEASURE: ",$$GET1^DIQ($$C0QQFN,ZI_",",.01),! ; PRINT THE MEASURE NAME
+	. ; FOLLOW THE POINTERS TO THE C0Q QUALITYM MEASURE FILE AND GET LIST PTRS
+	. S C0QNL=$$GET1^DIQ($$C0QQFN,ZI_",",1,"I") ; NUMERATOR POINTER
+	. I C0QNL="" D  ; CHECK ALTERNATE LIST
+	. . S C0QNL=$$GET1^DIQ($$C0QQFN,ZI_",",1.1,"I") ; NUMERATOR POINTER
+	. . I C0QNL'="" S C0QNALT=1
+	. S C0QDL=$$GET1^DIQ($$C0QQFN,ZI_",",2,"I") ; DENOMINATOR POINTER
+	       . I C0QDL="" D  ; CHECK ALTERNATE LIST
+	       . . S C0QDL=$$GET1^DIQ($$C0QQFN,ZI_",",2.1,"I") ; DENOMINATOR POINTER
+	       . . I C0QDL'="" S C0QDALT=1
+	. ; NOW FOLLOW THE LIST POINTERS TO THE REMINDER PATIENT LIST FILE
+	. ;W "NUMERATOR: ",$$GET1^DIQ($$RLSTFN,C0QNL_",","NAME"),!
+	. ; FIRST PROCESS THE NUMERATOR
+	. K ^TMP("DILIST",$J)
+	       . N C0QUFN ; FILE NUMBER TO USE
+	       . I $G(C0QNALT)=1 S C0QUFN=$$C0QALFN()
+	       . E  S C0QUFN=$$RLSTPFN
+	. D LIST^DIC(C0QUFN,","_C0QNL_",",".01I") ; GET THE LIST OF PATIENTS
+	. ;D DELIST("G") ;
+	. ;I $D(G) ZWR G
+	. K C0QNUMP
+	. S NCNT=$O(^TMP("DILIST",$J,"ID",""),-1) ; NUMERATOR COUNT
+	. N ZJ S ZJ=""
+	. F  S ZJ=$O(^TMP("DILIST",$J,"ID",ZJ)) Q:ZJ=""  D  ;
+	. . S ZDFN=^TMP("DILIST",$J,"ID",ZJ,.01)
+	. . S C0QNUMP("N",ZJ,ZDFN)=""
+	. ;I '$G(C0QSUM) ZWR ^TMP("DILIST",$J,1,*) ; LIST THE PATIENT NAMES
+	. D ADDPATS(MSET,ZII,"C0QNUMP")
+	. ; NEXT PROCESS THE DENOMINATOR
+	. ;W "DENOMINATOR: ",$$GET1^DIQ($$RLSTFN,C0QDL_",","NAME"),!
+	. K ^TMP("DILIST",$J)
+	       . I $G(C0QDALT)=1 S C0QUFN=$$C0QALFN()
+	       . E  S C0QUFN=$$RLSTPFN
+	. D LIST^DIC(C0QUFN,","_C0QDL_",",".01I") ; GET THE LIST OF PATIENTS
+	. ;D DELIST("G")
+	. ;I $D(G) ZWR G
+	. ;S ZJ=""
+	. S DCNT=$O(^TMP("DILIST",$J,"ID",""),-1) ; DENOMONIATOR COUNT
+	. K C0QDEMP
+	. F  S ZJ=$O(^TMP("DILIST",$J,"ID",ZJ)) Q:ZJ=""  D  ;
+	. . S ZDFN=^TMP("DILIST",$J,"ID",ZJ,.01)
+	. . S C0QDEMP("D",ZJ,ZDFN)=""
+	. D ADDPATS(MSET,ZII,"C0QDEMP")
+	. ;I $G(C0QSUM)'=1 ZWR ^TMP("DILIST",$J,1,*) ; LIST THE PATIENT NAMES
+	. ;E  D  ;
+	. ;. W "NUM CNT: ",NCNT
+	. ;. W "  DEN CNT: ",DCNT,!
+	Q
+	;
+CLEARMEA(MSET,MEAS)	; DELETE AND THEN RECREATE AS EMPTY THE
+	; MEASURE MEAS IN MEASURE SET IEN MSET
+	;
+	N C0QFDA,MFN,MEASURE
+	S MFN=$$C0QMMFN() ; FILE NUMBER FOR MEASURE SUBFILE
+	D CLEAN^DILF
+	S MEASURE=$$GET1^DIQ(MFN,MEAS_","_MSET_",",.01,"I") ;  MEASURE POINTER
+	D CLEAN^DILF
+	K ZERR
+	S C0QFDA(MFN,MEAS_","_MSET_",",.01)="@" ; GET READY TO DELETE THE MEASURE
+	D FILE^DIE(,"C0QFDA","ZERR") ; KILL THE SUBFILE
+	I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
+	;. W "ERROR",!
+	;. ZWR ZERR
+	;. B
+	K C0QFDA
+	S C0QFDA(MFN,"+1,"_MSET_",",.01)=MEASURE ; GET READY TO RECREATE THE SUBFILE
+	D UPDIE ; CREATE THE SUBFILE
+	Q
+	;
+ADDPATS(MSET,MEAS,PATS)	;ADD PATIENTS TO NUMERATOR AND DENOMINATOR
+	; OF MEASURE SET IEN MSET MEASURE IEN MEAS
+	; PATS IS OF THE FORM @PATS@("N",X,DFN)="" AND @PATS@("D",X,DFN)=""
+	; WHERE N IS FOR NUMERATOR AND D IS FOR DENOMINATOR AND X 1..N
+	; IF PATIENTS ARE ALREADY THERE, THEY WILL NOT BE ADDED AGAIN
+	N C0QI,C0QJ
+	N C0QFDA
+	S C0QI=""
+	F  S C0QI=$O(@PATS@("N",C0QI)) Q:C0QI=""  D  ; FOR EACH NUMERATOR PATIENT
+	. S C0QFDA($$C0QMMNFN,"?+"_C0QI_","_MEAS_","_MSET_",",.01)=$O(@PATS@("N",C0QI,""))
+	;W "ADDING NUMERATOR",!
+	;I $D(C0QFDA) ZWR C0QFDA
+	I $D(C0QFDA) D UPDIE
+	K C0QFDA
+	S C0QI=""
+	F  S C0QI=$O(@PATS@("D",C0QI)) Q:C0QI=""  D  ; FOR EACH NUMERATOR PATIENT
+	. S C0QFDA($$C0QMMDFN,"?+"_C0QI_","_MEAS_","_MSET_",",.01)=$O(@PATS@("D",C0QI,""))
+	;W "ADDING DENOMINATOR",!
+	;I $D(C0QFDA) ZWR C0QFDA
+	I $D(C0QFDA) D UPDIE
+	Q
+	;
+DELIST(RTN)	; DECODES ^TMP("DILIST",$J) INTO
+	; @RTN@(IEN)=INTERNAL VALUE^EXTERNAL VALUE
+	N ZI,IV,EV,ZDI,ZIEN
+	S ZI=""
+	S ZDI=$NA(^TMP("DILIST",$J))
+	K @RTN
+	F  S ZI=$O(@ZDI@(1,ZI)) Q:ZI=""  D  ;
+	. S EV=@ZDI@(1,ZI) ;EXTERNAL VALUE
+	. S IV=$G(@ZDI@("ID",ZI,.01)) ; INTERNAL VALUE
+	. S ZIEN=@ZDI@(2,ZI) ; IEN
+	. S @RTN@(ZIEN)=IV_"^"_EV
+	Q
+	;
+DELPATS(MSET,MEAS,NDEL)	; DELETE PATIENTS FROM NUMERATOR AND DENOMINATOR
+	; FOR A MEASURE (ONLY AFFECTS THE C0Q MEASURES FILE)
+	; MSET IS THE IEN OF THE MEASURE SET
+	; MEAS IS THE IEN OF THE MEASURE
+	; NDEL IS A LIST OF PATIENTS TO NOT DELETE (NOT IMPLEMENTED YET)
+	;  IN THE FORM @NDEL@("N",IEN,DFN)="" FOR NUMERATOR PATIENTS
+	;  AND @NDEL@("D",IEN,DFN)="" FOR DENOMINATOR PATIENTS WHERE IEN IS 
+	;  THE IEN OF THE PATIENT RECORD IN THE SUBFILE
+	;  THIS FEATURE WILL ALLOW EFFICIENCIES FOR LONG PATIENT LISTS
+	;  IN THAT PATIENTS THAT ARE GOING TO BE ADDED ARE NOT FIRST DELETED
+	N C0QI,C0QJ
+	D LIST^DIC($$C0QMMFN,","_MSET_",")
+	K C0QFDA
+	;ZWR ^TMP("DILIST",$J,*)
+	;ZWR ^TMP("DIERR",$J,*)
+	;D 
+	Q
+	;
 UPDIE	; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
- K ZERR
- D CLEAN^DILF
- D UPDATE^DIE("","C0QFDA","","ZERR")
- I $D(ZERR) D  ;
- . W "ERROR",!
- . ZWR ZERR
- . B
- K C0QFDA
- Q
- ;
+	K ZERR
+	D CLEAN^DILF
+	D UPDATE^DIE("","C0QFDA","","ZERR")
+	I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
+	;. W "ERROR",!
+	;. ZWR ZERR
+	;. B
+	K C0QFDA
+	Q
+	;
+QUE	;QUE THE RUN OF THE PATIENT LISTS AND THE BUILD THE LISTS OF THE PATIENTS
+	;AND THEIR MEASURES
+	S MSIEN=$$GET^XPAR("DIV."_$P($$SITE^VASITE(),U,2),"C0Q MEASUREMENT TO USE")
+	N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+	S ZTDESC="CREATE PATIENT LIST"
+	S ZTRTN="RUN^C0QMAIN"
+	S ZTSAVE("MSIEN")=""
+	S ZTIO=""
+	S ZTDTH=$$NOW^XLFDT
+	D ^%ZTLOAD
+	Q
+	;
+RUN	; DO THE REAL WORK
+	I '$D(MSIEN) S MSIEN=$$GET^XPAR("DIV."_$P($$SITE^VASITE(),U,2),"C0Q MEASUREMENT TO USE")
+	S BEG=$P(^C0Q(201,MSIEN,4),U,3) ;Begin date
+	S END=$P(^C0Q(201,MSIEN,4),U,4) ;End date
+	S PATCREAT="N" ;Secure list - N=No
+	S PLISTPUG="N" ;Purge list after 5 years - N=No
+	S PXRMDPAT=0 ;Include deceased patients - N=No
+	S PXRMTPAT=0 ;Include test patients - N=No
+	S PXRMNODE="PXRMRULE" ;Node in ^TMP($J,"PXRMRULE"
+	N ZI S ZI=""
+	F  S ZI=$O(^C0Q(201,MSIEN,5,"B",ZI)) Q:ZI'>0  D  ; LOOP THROUGH EACH QM
+	. S PXRMLSTN=+$P(^C0Q(101,ZI,0),U,2) ; NUMERATOR MEASURE
+	. S PXRMLSTD=+$P(^C0Q(101,ZI,0),U,3) ; DENOMINATOR MEASURE
+	. S PXRMRULN=+$P(^PXRMXP(810.5,PXRMLSTN,0),U,6) ; RULES FOR THE LIST
+	. S PXRMRULD=+$P(^PXRMXP(810.5,PXRMLSTD,0),U,6)
+	. D RUN^PXRMLCR(PXRMRULD,PXRMLSTD,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)
+	. D RUN^PXRMLCR(PXRMRULN,PXRMLSTN,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)
+	D C0QRPC(.G,MSIEN)
+	Q
Index: /qrda/C0Q/trunk/p/C0QPQRI.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QPQRI.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QPQRI.m	(revision 1223)
@@ -0,0 +1,180 @@
+C0QPQRI	  ; GPL - GENERATES A PQRI XML FILE ;6/14/11  17:05
+	;;0.1;C0C;nopatch;noreleasedate;Build 13
+	;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
+	;General Public License See attached copy of the License.
+	;
+	;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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
+	;
+	Q
+	;
+C0QQFN()	Q 1130580001.101 ; FILE NUMBER FOR C0Q QUALITY MEASURE FILE
+C0QMFN()	Q 1130580001.201 ; FILE NUMBER FOR C0Q MEASUREMENT FILE
+C0QMMFN()	Q 1130580001.2011 ; FN FOR MEASURE SUBFILE
+C0QMMNFN()	Q 1130580001.20111 ; FN FOR NUMERATOR SUBFILE
+C0QMMDFN()	Q 1130580001.20112 ; FN FOR DENOMINATOR SUBFILE
+RLSTFN()	Q 810.5 ; FN FOR REMINDER PATIENT LIST FILE
+RLSTPFN()	Q 810.53 ; FN FOR REMINDER PATIENT LIST PATIENT SUBFILE
+	;
+EN	; 
+	; lets try some hard coded values for now
+	N C0QVAR
+	;
+	; first, the values that occur only once for the file
+	;
+	S C0QVAR("create-by")="RegistryA"
+	S C0QVAR("create-date")="12-10-2010"
+	S C0QVAR("create-time")="14:27"
+	S C0QVAR("file-number")=1
+	S C0QVAR("number-of-files")=9
+	S C0QVAR("version")="1.0"
+	;
+	; registry values
+	;
+	S C0QVAR("registry-id")=125789123
+	S C0QVAR("registry-name")="Model Registry"
+	S C0QVAR("submission-method")="C"
+	;
+	; values for each provider
+	;
+	S C0QVAR("npi")=12011989
+	S C0QVAR("tin")=387682321
+	S C0QVAR("waiver-signed")="Y"
+	S C0QVAR("encounter-from-date")="06-13-2010"
+	S C0QVAR("encounter-to-date")="12-10-2010"
+	;
+	; values for each measure group
+	;
+	S C0QVAR("ffs-patient-count")=2
+	S C0QVAR("group-eligible-instances")=30
+	S C0QVAR("group-reporting-rate")=66.67
+	S C0QVAR("group-reporting-rate-numerator")=20
+	;
+	; for each measure
+	;
+	S C0QVAR("pqri-measure-number")=128
+	S C0QVAR("eligible-instances")=100
+	S C0QVAR("meets-performance-instances")=18
+	S C0QVAR("performance-exclusion-instances")=0
+	S C0QVAR("performance-not-met-instances")=10
+	S C0QVAR("performance-rate")="90.00"
+	S C0QVAR("reporting-rate")="28.00"
+	;
+	;
+	N ZG,ZV
+	D GETTEMP^C0CMXP("ZG","PQRIXML") ; GET THE TEMPLATE
+	D BIND^C0CSOAP("ZV","C0QVAR","PQRIXML") ; GET BINDING VALUES
+	D MAP^C0CXPATH("ZG","ZV","ZO") ; MAP THE XML
+	D MEA("GG","GGG") ; GET THE MEASURES
+	N GB ; BUILD LIST
+	D QUEUE^C0CXPATH("GB","ZO",1,30) ; first part of pqri.xml
+	D QUEUE^C0CXPATH("GB","GG",2,$O(GG(""),-1)-1) ; the measures
+	D QUEUE^C0CXPATH("GB","ZO",$O(ZO(""),-1)-2,$O(ZO(""),-1)) ; LAST LINES
+	D BUILD^C0CXPATH("GB","GZO") ; BUILD THE XML
+	N ZI S ZI=0
+	F  S ZI=$O(ZO(ZI)) Q:ZI=""  D  ; FOR EACH LINE OF XML
+	. W !,GZO(ZI) ; WRITE OUT THE XML
+	N GN,GN1,GD S GN=$NA(^TMP("C0QXML",$J))
+	K @GN
+	K ZO(0) ; GET RID OF LINE COUNT
+	M @GN=GZO
+	S GN1=$NA(@GN@(1))
+	S GD=$G(^TMP("C0CCCR","ODIR")) ; CONVENIENT OUTPUT DIRECTORY
+	W $$OUTPUT^C0CXPATH(GN1,"pqri.xml",GD)
+	K @GN ; DONT NEED IT ANYMORE
+	Q
+	;
+INSERT(ZARY,ZONE)	; INSERT ONE MEASURE INTO THE ARRAY
+	;
+	;N GGG
+	S GGG="//submission/measure-group ID='C'/provider/pqri-measure" ;XPATH
+	D INSINNER^COCXPATH(ZARY,GGG,ZONE) ; INSERT XML
+	Q
+	;
+PQRI(ZOUT,KEEP)	; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE
+	;
+	N ZG
+	S ZG=$NA(^TMP("PQRIXML",$J))
+	K @ZG
+	D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML
+	N C0CDOCID
+	S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML
+	D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS
+	I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
+	Q
+	;
+PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP)	; PARSE AND RUN DOMO ON XML
+	; ZRTN IS PASSED BY REFERENCE
+	; ZXML IS PASSED BY NAME
+	; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED
+	;
+	N ZG
+	S ZG=$NA(^TMP("C0CXML",$J))
+	K @ZG
+	M @ZG=@ZXML
+	S C0CDOCID=$$PARSE^C0CDOM(ZG,"NHINARRAY") ; PARSE WITH MXML
+	D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS
+	I '$G(KEEP) K GIDX,GARY,@ZG ; GET RID OF THE ARRAYS UNLESS KEEP=1
+	Q
+	;
+GETFM(RTN,ZREC)	; GET THE QUALITY MEASURES ARRAY
+	;
+	I '$D(ZREC) S ZREC=7 ; OUTPATIENT CERTIFICATION SET
+	;N GPL
+	D LIST^DIC($$C0QMMFN(),","_ZREC_",",".01;1.1;2.1;3;",,,,,,,,"GPL")
+	N ZI S ZI=""
+	F  S ZI=$O(GPL("DILIST","ID",ZI)) Q:ZI=""  D  ;
+	. S @RTN@(ZI,"measure")=GPL("DILIST","ID",ZI,.01)
+	. N ZMIEN,ZMEAIEN,ZRNAME
+	. S ZMIEN=GPL("DILIST",2,ZI) ; IEN OF MEASURE IN MEASURE FILE
+	. ;S ZMEAIEN=$$GET1^DIQ($$C0QMMFN(),ZMIEN_","_ZREC_",",.01,"I") ; MEASURE
+	. S ZRNAME=$$GET1^DIQ($$C0QMMFN(),ZMIEN_","_ZREC_",",".01:.8") ; MEASURE
+	. ;S @RTN@(ZI,"reportingName")=$$GET1^DIQ($$C0QQFN(),ZMEAIEN_",",.8) ; RNAME
+	. S @RTN@(ZI,"reportingName")=ZRNAME ; A SHORTCUT TO THE REPORTING NAME
+	. S @RTN@(ZI,"reportingNumber")=$P(ZRNAME,"NQF",2) ; NQF0001 -> 0001
+	. S @RTN@(ZI,"denominator")=+GPL("DILIST","ID",ZI,2.1)
+	. S @RTN@(ZI,"numerator")=+GPL("DILIST","ID",ZI,1.1)
+	. N ZNUM,ZDEM,ZPCT
+	. S (ZNUM,ZDEM,ZPCT)=0
+	. S ZDEM=+GPL("DILIST","ID",ZI,2.1)
+	. S ZNUM=+GPL("DILIST","ID",ZI,1.1)
+	. I ZDEM>0 S ZPCT=((ZNUM*100)/ZDEM)
+	. S @RTN@(ZI,"percent")=$P(ZPCT,".",1)
+	. S @RTN@(ZI,"ien")=ZI
+	;ZWR GPL
+	Q
+	;
+MEA(ZOUT,ZIN)	; CREATE XML FROM THE MEASURES ARRAY
+	;
+	D GETFM(ZIN) ;  GET THE MEASURES
+	;N G
+	;N ZI,ZJ
+	S ZI=""
+	F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
+	. N ZDEN,ZNUM,ZPCT
+	. S ZDEN=$G(@ZIN@(ZI,"denominator"))
+	. S ZNUM=$G(@ZIN@(ZI,"numerator"))
+	. S ZPCT=$G(@ZIN@(ZI,"percent"))
+	. S G("pqri-measure",ZI,"eligible-instances")=ZDEN
+	. S G("pqri-measure",ZI,"meets-performance-instances")=ZNUM
+	. S G("pqri-measure",ZI,"performance-exclusion-instances")=0
+	. S G("pqri-measure",ZI,"performance-not-met-instances")=ZDEN-ZNUM
+	. S G("pqri-measure",ZI,"performance-rate")=ZPCT
+	. S G("pqri-measure",ZI,"pqri-measure-number")="NQF "_@ZIN@(ZI,"reportingNumber")
+	. S G("pqri-measure",ZI,"reporting-rate")=ZPCT
+	K ^TMP("MXMLDOM",$J)
+	S C0CDOCID=$$DOMI^C0CDOM("G",1,"root")
+	D OUTXML^C0CDOM(ZOUT,C0CDOCID,1)
+	Q
+	;
Index: /qrda/C0Q/trunk/p/C0QPRML.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QPRML.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QPRML.m	(revision 1223)
@@ -0,0 +1,319 @@
+C0QPRML	;JJOH/ZAG/GPL - Patient Reminder List ;7/5/11 8:50pm
+	;;1.0;MU PACKAGE;;;Build 13
+	;
+	;2011 Zach Gonzales<zach@linux.com> - Licensed under the terms of the GNU
+	;General Public License See attached copy of the License.
+	;
+	;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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
+	;
+BUILD	; CALL ALL AND DIS AND BUILD THE GRSLT ARRAY or print or create
+	; patient lists
+	;N GRSLT ; ARRAY FOR RESULTS
+	I '$D(C0QSS) S C0QSS=0 ;default don't build spreadsheet array
+	I '$D(C0QPR) S C0QPR=0 ;default don't print out results
+	I '$D(C0QPL) S C0QPL=1 ;default do create patient lists
+	N G1 ; ONE SET OF VALUES - RNF1 FORMAT
+	D ALL ; all currently admitted patients in the hospital
+	D DIS ; all patients discharged since the reporting period began
+	I C0QSS ZWR GRSLT
+	I C0QPL D FILE ; FILE THE PATIENT LISTS
+	Q
+	;
+ALL	;retrieve active inpatients
+	N WARD S WARD=""
+	F  D  Q:WARD=""
+	. S WARD=$O(^DIC(42,"B",WARD)) ;ward name
+	. Q:WARD=""
+	. N WIEN S WIEN=""
+	. F  S WIEN=$O(^DIC(42,"B",WARD,WIEN)) Q:'WIEN  D  ;wards IEN
+	. . S WARDNAME=$P(^DIC(42,WIEN,0),U,2) ;ward name
+	. . N DFN,RB S DFN=""
+	. . F  S DFN=$O(^DPT("CN",WARD,+DFN)) Q:'DFN  D  ;DFN of patient on ward
+	. . . D DEMO
+	. . . D PROBLEM
+	. . . D ALLERGY
+	. . . D MEDS
+	. . . I C0QPR D PRINT
+	. . . I C0QSS D SS
+	. . . I C0QPL D PATLIST
+	Q
+	;
+DEMO	; patient demographics
+	S PTNAME=$P(^DPT(DFN,0),U) ;patient name
+	S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
+	S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
+	D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
+	S PTHRN=$P($G(VA("PID")),U) ;health record number
+	S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
+	I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
+	S RACE=""
+	F  D  Q:RACE=""
+	. S RACE=$O(^DPT(DFN,.02,"B",RACE)) ;race code IEN
+	. Q:'RACE
+	. S RACEDSC=$P($G(^DIC(10,RACE,0)),U) ;race description
+	S ETHN=""
+	F  D  Q:ETHN=""
+	. S ETHN=$O(^DPT(DFN,.06,"B",ETHN)) ;ethnicity IEN
+	. Q:'ETHN
+	. S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U) ;ethnincity description
+	S RB=$P(^DPT(DFN,.101),U) ;room and bed
+	Q
+	;
+PROBLEM	; PATIENT PROBLEMS
+	D LIST^ORQQPL(.PROBL,DFN,"A")
+	S PBCNT=""
+	F  S PBCNT=$O(PROBL(PBCNT)) Q:PBCNT=""  D
+	. S PBDESC=$P(PROBL(PBCNT),U,2) ;problem description
+	K PROBL
+	Q
+	; 
+ALLERGY	; ALLERGY LIST
+	D LIST^ORQQAL(.ALRGYL,DFN)
+	S ALCNT=""
+	F  S ALCNT=$O(ALRGYL(ALCNT)) Q:ALCNT=""  D
+	. S ALDESC=$P(ALRGYL(ALCNT),U,2) ;allergy description
+	K ALRGYL
+	Q
+	;
+MEDS	; MEDICATIONS
+	D COVER^ORWPS(.MEDSL,DFN)
+	S MDCNT=""
+	F  S MDCNT=$O(MEDSL(MDCNT)) Q:MDCNT=""  D
+	. Q:$P(MEDSL(MDCNT),U,4)'="ACTIVE"  ;active medications only
+	. S MDDESC=$P(MEDSL(MDCNT),U,2) ;medication description
+	. S MDITEM=$P($G(MEDSL(MDCNT)),U,3)
+	K MEDSL
+	Q
+	;
+PRINT	; PRINT TO SCREEN
+	
+	I $D(WARD) W !!,WARD_"-"_WARDNAME_" "_RB_": "_PTNAME_"("_PTSEX_") "
+	I $D(EXDTE) D  ;
+	. W !,"Discharge Date: ",EXDTE
+	. W !,DFN," ",PTNAME
+	W !,"DOB: ",PTDOB," HRN: ",PTHRN
+	W !,"Language Spoken: ",$G(PTLANG)
+	W !,"Race: ",RACEDSC
+	W !,"Ethnicity: ",$G(ETHNDSC)
+	W !,"Problems: "
+	W !,PBDESC
+	W !,"Allergies: "
+	W !,ALDESC
+	W !,"Medications: "
+	W !
+	Q
+	;
+SS	; CREATE SPREADSHEET ARRAY
+	S G1("Patient")=DFN
+	I $D(WARD) D  ;
+	. S G1("WardName")=WARDNAME
+	. S G1("RoomAndBed")=RB
+	I $D(EXDTE) D ; 
+	. S G1("DischargeDate")=EXDTE
+	S G1("PatientName")=PTNAME
+	S G1("Gender")=PTSEX
+	S G1("DateOfBirth")=PTDOB
+	S G1("HealthRecordNumber")=PTHRN
+	S G1("LanguageSpoken")=$G(PTLANG)
+	S G1("Race")=RACEDSC
+	S G1("Ehtnicity")=$G(ETHNDSC)
+	S G1("Problem")=PBDESC
+	I PBDESC["No problems found" S G1("HasProblem")=0
+	E  S G1("HasProblem")=1
+	S G1("Allergies")=ALDESC
+	I ALDESC["No Allergy" S G1("HasAllergy")=0
+	E  S G1("HasAllergy")=1
+	I $D(MDITEM) D  ;
+	. S G1("HasMed")=1
+	E  S G1("HasMed")=0
+	S G1("MedDescription")=$G(MDDESC)
+	I $D(MDITEM) W !,"("_MDITEM_")"_MDDESC E  W !,MDDESC
+	D RNF1TO2B^C0CRNF("GRSLT","G1")
+	K G1
+	Q  ; DON'T WANT TO DO THE NHIN STUFF NOW
+	;
+PATLIST	; CREATE PATIENT LISTS
+	S C0QLIST("Patient",DFN)="" ; THE PATIENT LIST
+	N DEMOYN S DEMOYN=1
+	I $G(PTSEX)="" S DEMOYN=0
+	I $G(PTDOB)="" S DEMOYN=0
+	I $G(PTHRN)="" S DEMOYN=0
+	I $G(PTLANG)="" S DEMOYN=0
+	I $G(RACEDSC)="" S DEMOYN=0
+	I $G(ETHNDSC)="" S DEMOYN=0
+	I DEMOYN S C0QLIST("HasDemographics",DFN)=""
+	E  S C0QLIST("FailedDemographics",DFN)=""
+	;S G1("Gender")=PTSEX
+	;S G1("DateOfBirth")=PTDOB
+	;S G1("HealthRecordNumber")=PTHRN
+	;S G1("LanguageSpoken")=$G(PTLANG)
+	;S G1("Race")=RACEDSC
+	;S G1("Ehtnicity")=$G(ETHNDSC)
+	S G1("Problem")=PBDESC
+	I PBDESC["No problems found" S C0QLIST("NoProblem",DFN)=""
+	E  S C0QLIST("HasProblem",DFN)=""
+	;S G1("Allergies")=ALDESC
+	I ALDESC["No Allergy" S C0QLIST("NoAllergy",DFN)=""
+	E  S C0QLIST("HasAllergy",DFN)=""
+	I $D(MDITEM) D  ;
+	. S C0QLIST("HasMed",DFN)=""
+	E  S G1("NoMed",DFN)=""
+	;S G1("MedDescription")=$G(MDDESC)
+	Q
+	;
+NHIN	; SHOW THE NHIN ARRAY FOR THIS PATIENT
+	Q:DFN=137!14
+	D EN^C0CNHIN(.G,DFN,"")
+	ZWR G
+	K G
+	;
+	QUIT  ;end of WARD
+	;
+	;
+DIS;	
+	N DFN,DTE,EXDTE S DTE=""
+	F  D  Q:DTE=""
+	. S DTE=$O(^DGPM("B",DTE))
+	. Q:'DTE
+	. Q:DTE<3110703
+	. S EXDTE=$$FMTE^XLFDT(DTE)
+	. N PTFM S PTFM=""
+	. D
+	. . S PTFM=$O(^DGPM("B",DTE,PTFM))
+	. . Q:'PTFM
+	. . S DFN=$P(^DGPM(PTFM,0),U,3)
+	. . D DEMO
+	. . D PROBLEM
+	. . D ALLERGY
+	. . D MEDS
+	. . I C0QPR D PRINT
+	. . I C0QSS D SS
+	. . I C0QPL D PATLIST
+	Q
+	;
+C0QPLF()	Q 1130580001.301 ; FILE NUMBER FOR C0Q PATIENT LIST FILE
+C0QALFN()	Q 1130580001.311 ; FILE NUMBER FOR C0Q PATIENT LIST PATIENT SUBFILE
+FILE	; FILE THE PATIENT LISTS TO C0Q PATIENT LIST
+	;
+	I '$D(C0QLIST) Q  ;
+	N LFN S LFN=$$C0QALFN()
+	N ZI,ZN
+	S ZI=""
+	F  S ZI=$O(C0QLIST(ZI)) Q:ZI=""  D  ;
+	. S ZN=$O(^C0Q(301,"CATTR",ZI,""))
+	. I ZN="" D  Q  ; OOPS
+	. . W !,"ERROR, ATTRIBUTE NOT FOUND IN PATIENT LIST FILE:"_ZI
+	. S ZN=$$KLNCR(ZN) ; KILL AND RECREATE RECORD ZN
+	. K C0QFDA
+	. N ZJ,ZC
+	. S ZJ="" S ZC=1
+	. F  S ZJ=$O(C0QLIST(ZI,ZJ)) Q:ZJ=""  D  ; FOR EACH PAT IN LIST
+	. . S C0QFDA(LFN,"?+"_ZC_","_ZN_",",.01)=ZJ
+	. . S ZC=ZC+1
+	. D UPDIE
+	. W !,"FOUND:"_ZI
+	Q
+	;
+KLNCR(ZREC)	; KILL AND RECREATE RECORD ZREC IN PATIENT LIST FILE
+	;
+	N C0QFDA,ZFN,LIST,ATTR
+	S ZFN=$$C0QPLF() ; FILE NUMBER FOR C0Q PATIENT LIST FILE
+	D CLEAN^DILF
+	S LIST=$$GET1^DIQ(ZFN,ZREC_",",.01) ;  MEASURE NAME
+	S ATTR=$$GET1^DIQ(ZFN,ZREC_",",999) ; ATTRIBUTE
+	D CLEAN^DILF
+	K ZERR
+	S C0QFDA(ZFN,ZREC_",",.01)="@" ; GET READY TO DELETE THE MEASURE
+	D FILE^DIE(,"C0QFDA","ZERR") ; KILL THE SUBFILE
+	I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
+	;. W "ERROR",!
+	;. ZWR ZERR
+	;. B
+	K C0QFDA
+	S C0QFDA(ZFN,"+1,",.01)=LIST ; GET READY TO RECREATE THE RECORD
+	S C0QFDA(ZFN,"+1,",999)=ATTR ; ATTRIBUTE
+	D UPDIE ; CREATE THE SUBFILE
+	N ZR ; NEW IEN FOR THE RECORD
+	S ZR=$O(^C0Q(301,"CATTR",ATTR,""))
+	;
+	Q ZR
+	;
+UPDIE	; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
+	K ZERR
+	D CLEAN^DILF
+	D UPDATE^DIE("","C0QFDA","","ZERR")
+	I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
+	;. W "ERROR",!
+	;. ZWR ZERR
+	;. B
+	K C0QFDA
+	Q
+	;
+	; WHAT FOLLOWS IS OLD CODE - DELETE WHEN THIS WORKS
+	;. . N PTNAME S PTNAME=$P(^DPT(DFN,0),U,1)
+	;. . S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
+	;. . S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
+	;. . D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
+	;. . S PTHRN=$P($G(VA("PID")),U) ;health record number
+	;. . S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
+	;. . I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
+	;. . S RACE=""
+	;. . F  D  Q:RACE=""
+	;. . . S RACE=$O(^DPT(DFN,.02,"B",RACE))
+	;. . . Q:'RACE
+	;. . . S RACEDSC=$P($G(^DIC(10,RACE,0)),U)
+	;. . N ETHNDSC
+	;. . N ETHNDSC S ETHNDSC=""
+	;. . S ETHN=""
+	;. . F  D  Q:ETHN=""
+	;. . . S ETHN=$O(^DPT(DFN,.06,"B",ETHN))
+	;. . . Q:'ETHN
+	;. . . S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U)
+	;. . D LIST^ORQQPL(.PROBL,DFN,"A")
+	;. . S PBCNT=""
+	;. . F  S PBCNT=$O(PROBL(PBCNT)) Q:PBCNT=""  D
+	;. . . S PBDESC=$P(PROBL(PBCNT),U,2) ;problem description
+	;. . K PROBL
+	;. . D LIST^ORQQAL(.ALRGYL,DFN)
+	;. . S ALCNT=""
+	;. . F  S ALCNT=$O(ALRGYL(ALCNT)) Q:ALCNT=""  D
+	;. . . S ALDESC=$P(ALRGYL(ALCNT),U,2) ;allergy description
+	;. . K ALRGYL
+	;. . D COVER^ORWPS(.MEDSL,DFN)
+	;. . S MDCNT=""
+	;. . F  S MDCNT=$O(MEDSL(MDCNT)) Q:MDCNT=""  D
+	;. . . Q:$P(MEDSL(MDCNT),U,4)'="ACTIVE"  ;active medications only
+	;. . . S MDDESC=$P(MEDSL(MDCNT),U,2) ;medication description
+	;. . . S MDITEM=$P($G(MEDSL(MDCNT)),U,3)
+	;. . K MEDSL
+	;. . W !,"Discharge Date: ",EXDTE
+	;. . W !,DFN," ",PTNAME
+	;. . W !,"DOB: ",PTDOB," HRN: ",PTHRN
+	;. . W !,"Language Spoken: ",$G(PTLANG)
+	;. . W !,"Race: ",RACEDSC
+	;. . W !,"Ethnicity: ",ETHNDSC
+	;. . W !,"Problems: "
+	;. . W !,PBDESC
+	;. . W !,"Allergies: "
+	;. . W !,ALDESC
+	;. . W !,"Medications: "
+	;. . I $D(MDITEM) W !,"(",MDITEM,")",MDDESC E  W !,MDDESC
+	;. . W !
+	;Q
+	;
+	;
+	;
+	;
+END	;end of C0QPRML;
Index: /qrda/C0Q/trunk/p/C0QSET.m
===================================================================
--- /qrda/C0Q/trunk/p/C0QSET.m	(revision 1223)
+++ /qrda/C0Q/trunk/p/C0QSET.m	(revision 1223)
@@ -0,0 +1,112 @@
+C0QSET	;GPL - SET OPERATIONS ON LISTS ;818/11 8:50pm
+	;;1.0;MU PACKAGE;;;Build 13
+	;
+	;2011 George Lilly glilly@glilly.net - Licensed under the terms of the GNU
+	;General Public License See attached copy of the License.
+	;
+	;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 Street, Fifth Floor, Boston, MA 02110-1301 USA.
+	;
+	Q
+	;
+TEST	; TEST OF UNITY ROUTINE
+	;
+	S A(1)=""
+	S A(2)=""
+	S A(3)=""
+	S B(3)=""
+	S B(4)=""
+	D UNITY("C","A","B")
+	ZWR C
+	Q
+	;
+TEST2	; WHICH PATIENTS HAVE MEDICATIONS? WHICH DON'T? 
+	; WHAT BAD PATIENT POINTERS ARE IN THE MEDICATIONS FILE?
+	S PATS=$NA(^DPT)
+	S MEDS=$NA(^PS(55))
+	D UNITY("DELTA",PATS,MEDS)
+	W !,"PATIENTS WITH NO MEDS",!
+	ZWR DELTA(0,*)
+	W !,"BAD POINTERS IN THE MEDS FILE",!
+	ZWR DELTA(2,*)
+	Q
+	;
+UNITY(ZRTN,ZNEW,ZOLD)	; RETURNS THE DELTA BETWEEN THE NEW AND OLD LISTS
+	; ONLY NUMERIC LISTS SUPPORTED. FOR LIST WITH STRINGS SEE UNITYS
+	; ZRTN,ZNEW AND ZOLD ARE ALL PASSED BY NAME
+	; FORMAT OF RETURN ARRAY:
+	; @ZRTN@(0,X)="" ; X IS MISSING FROM OLD
+	; @ZRTN@(1,Y)="" ; Y IS IN BOTH NEW AND OLD - NOT MISSING
+	; @ZRTN@(2,Z)="" ; Z IS EXTRA IN OLD - WOULD BEED TO BE DELETED FOR UNITY
+	N C0QD ; TEMP WORK ARRAY
+	N ZI S ZI=0
+	F  S ZI=$O(@ZNEW@(ZI)) Q:+ZI=0  D  ; FOR EACH ITEM IN NEW
+	. S C0QD(ZI)=0 ; SET THEM ALL AS 0 MEANING NEW
+	S ZI=0
+	F  S ZI=$O(@ZOLD@(ZI)) Q:+ZI=0  D  ; FOR EACH ITEM IN OLD
+	. I $D(C0QD(ZI)) S C0QD(ZI)=1 ; NOT NEW - PRESENT IN NEW AND OLD
+	. E  S C0QD(ZI)=2 ; EXTRA IN OLD - WOULD NEED TO BE DELETED
+	S ZI=0
+	F  S ZI=$O(C0QD(ZI)) Q:+ZI=0  D  ; FOR EACH ITEM
+	. S @ZRTN@(C0QD(ZI),ZI)="" ; SET RESULTS IN RETURN ARRAY
+	Q
+	;
+UNITYS(ZRTN,ZNEW,ZOLD)	; RETURNS THE DELTA BETWEEN THE NEW AND OLD LISTS
+	; THIS VERSION HAS SUPPORT FOR NUMBERS AND STRINGS IN A LIST
+	; ZRTN,ZNEW AND ZOLD ARE ALL PASSED BY NAME
+	; FORMAT OF RETURN ARRAY:
+	; @ZRTN@(0,X)="" ; X IS MISSING FROM OLD
+	; @ZRTN@(1,Y)="" ; Y IS IN BOTH NEW AND OLD - NOT MISSING
+	; @ZRTN@(2,Z)="" ; Z IS EXTRA IN OLD - WOULD BEED TO BE DELETED FOR UNITY
+	N C0QD ; TEMP WORK ARRAY
+	N ZI S ZI=""
+	F  S ZI=$O(@ZNEW@(ZI)) Q:ZI=""  D  ; FOR EACH ITEM IN NEW
+	. S C0QD(ZI)=0 ; SET THEM ALL AS 0 MEANING NEW
+	S ZI=""
+	F  S ZI=$O(@ZOLD@(ZI)) Q:ZI=""  D  ; FOR EACH ITEM IN OLD
+	. I $D(C0QD(ZI)) S C0QD(ZI)=1 ; NOT NEW - PRESENT IN NEW AND OLD
+	. E  S C0QD(ZI)=2 ; EXTRA IN OLD - WOULD NEED TO BE DELETED
+	S ZI=""
+	F  S ZI=$O(C0QD(ZI)) Q:ZI=""  D  ; FOR EACH ITEM
+	. S @ZRTN@(C0QD(ZI),ZI)="" ; SET RESULTS IN RETURN ARRAY
+	Q
+	;
+AND(ZRTN,ZNEW,ZOLD)	; RETURNS A LIST OF WHAT IS COMMON TO BOTH NEW AND OLD
+	N ZD
+	D UNITY("ZD",ZNEW,ZOLD)
+	M @ZRTN=ZD(1)
+	Q
+	;
+NAND(ZRTN,ZNEW,ZOLD)	; RETURNS WHAT IS IN A OR B BUT NOT BOTH
+	N ZD
+	D UNITY("ZD",ZNEW,ZOLD)
+	M @ZRTN=ZD(0)
+	M @ZRTN=ZD(2)
+	Q
+	;
+AMINUSB(ZRTN,ZA,ZB)	; WHAT'S LEFT IN A AFTER REMOVING B FROM IT
+	N ZD
+	D UNITY("ZD",ZA,ZB)
+	M @ZRTN=ZD(0)
+	Q
+	;
+OR(ZRTN,ZA,ZB)	; WHAT'S IN A OR B OR BOTH
+	N ZD
+	D UNITY("ZD",ZA,ZB)
+	M @ZRTN=ZD(0)
+	M @ZRTN=ZD(1)
+	M @ZRTN=ZD(2)
+	Q
+	;
+END	;end of C0QSET;