BIUTL6 ;IHS/CMI/MWR - UTIL: TEXT FOR POINTERS; MAY 10, 2010
;;8.5;IMMUNIZATION;**9**;OCT 01,2014
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; UTILITY: TEXT FOR PROVIDER, HOSP LOC, INSTIT, OTHER LOC,
;; TRANSLATIONS, REACTION, CONTRA, SITE HDR, CUR COM TXT.
;; PATCH 3: Add call to return Imm Date if 1201 Event Date is populated IMMDT
;; PATCH 9: Allow return of 1201 Event or NULL, by not passing BIVPTR. IMMDT+12
;
;
;----------
USERPOP(BIDFN,BIEDATE) ;EP - Return 1 if Patient is in User Population as of BIEDATE.
;---> Code from Lori Butcher, CMI, Feb 2010.
;---> Return 1 if Patient is in User Population; otherwise return 0.
;---> Parameters:
; 1 - BIDFN (req) Patient DFN.
; 2 - BIEDATE (req) Date as of which Patient is an in User Population.
; User Population = 1 or more qualifying visits in last 3 years.
;
I '$D(^AUPNPAT(BIDFN,0)) Q 0 ;invalid patient
I '$D(^AUPNVSIT("AC",BIDFN)) Q 0 ;patient has no visits
;
NEW A,B,E,G,X,BIBDATE
S BIBDATE=$$FMADD^XLFDT(BIEDATE,-1096) ;get beginning date for search, 3 yrs ago (1096 days)
K ^TMP($J,"ALL VISITS")
S A="^TMP($J,""ALL VISITS"","
S B=BIDFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BIBDATE)_"-"_$$FMTE^XLFDT(BIEDATE)
S E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"ALL VISITS",1)) Q 0
S (X,UP)=0
F S X=$O(^TMP($J,"ALL VISITS",X)) Q:((X'=+X)!(UP)) S V=$P(^TMP($J,"ALL VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V)) ;MUST BE A COMPLETE VISIT
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7) ;must be ambulatory, hosp, day surgery or obervation
.Q:"V"[$P(^AUPNVSIT(V,0),U,3) ;can't be a VA type visit
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.S UP=1 ;has at least one visit so in user pop
Q UP
;
;
;----------
ACTCLIN(BIDFN,BIEDATE) ;EP - Return 1 if Patient is Active Clinical User as of BIEDATE.
;---> Code from Lori Butcher, CMI, Feb 2010.
;---> Return 1 if Patient is Active Clinical; otherwise return 0.
;---> Parameters:
; 1 - BIDFN (req) Patient DFN.
; 2 - BIEDATE (req) Date as of which Patient is an Active Clinical User.
; Active Clinical = 2 or more qualifying visits in last 3 years.
;
I '$D(^AUPNPAT(BIDFN,0)) Q 0 ;invalid patient
I '$D(^AUPNVSIT("AC",BIDFN)) Q 0 ;patient has no visits
;
NEW A,B,E,G,X,BIBDATE,AC,S,F,BIGPRAYR
S BIBDATE=$$FMADD^XLFDT(BIEDATE,-1096) ;get begin date for search, 3 yrs ago (1096 days)
K ^TMP($J,"ALL VISITS")
;
;---> Get IEN of GPRA Control File entry.
S BIGPRAYR=$$GPRAIEN
I 'BIGPRAYR Q 0
;
S A="^TMP($J,""ALL VISITS"","
S B=BIDFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BIBDATE)_"-"_$$FMTE^XLFDT(BIEDATE)
S E=$$START1^APCLDF(B,A)
;
I '$D(^TMP($J,"ALL VISITS",1)) Q 0
S (X,G,AC,S,F)=0
F S X=$O(^TMP($J,"ALL VISITS",X)) Q:((X'=+X)!(AC)) S V=$P(^TMP($J,"ALL VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V)) ;MUST BE A COMPLETE VISIT
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7) ;must be ambulatory, hosp, day surgery or obervation
.Q:"V"[$P(^AUPNVSIT(V,0),U,3) ;can't be a VA type visit
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.S B=$$CLINIC^APCLV(V,"C") ;get clinic for active clinical check
.Q:B=""
.I 'G,$D(^BGPCTRL(BIGPRAYR,11,"B",B)) S G=V ;must be a primary clinic
.I V'=G,$D(^BGPCTRL(BIGPRAYR,12,"B",B)) S S=1 ;has a secondary type of clinic
.I G,S S AC=1 ;if have both then they are active clinical
.Q
Q AC
;
;
;----------
GPRAIEN() ;EP
;---> Return GPRA Control File IEN
;
;---> Get the most recent GPRA Year Control file entry.
N BIYR,BIGPIEN
S BIYR=$O(^BGPCTRL("B",""),-1)
Q:'BIYR 0
S BIGPIEN=$O(^BGPCTRL("B",BIYR,0))
Q:'BIGPIEN 0
Q:('$G(^BGPCTRL(BIGPIEN,0))) 0
Q BIGPIEN
;
;
;----------
PROV200(X) ;EP
;---> Given PROVIDER's IEN in File #3, return the IEN in File #200.
;---> Parameters:
; 1 - X (req) =IEN in old PROVIDER File #6.
;
Q:'$G(X) ""
Q $G(^DIC(16,X,"A3"))
;
;
;----------
PROVIDER(X) ;EP
;---> Code to check whether to return File 6 or File 200 for
;---> Provider. ** Not used so far. **
;
Q:'X ""
;---> IF PCC WANTS A FILE 6 POINTER FOR PROVIDER, RESET X.
I '$P(^AUTTSITE(1,0),U,22) D
.I $P($G(^VA(200,X,0)),U,16) S X=$P(^(0),U,16) Q
.S X=$P($G(^DIC(3,X,0)),U,16)
Q X
;
;
;----------
REACTXT(X) ;EP
;---> Return text of Reaction to Immunization.
;---> Parameters:
; 1 - X (req) =IEN in IMMUNIZATION File #9002084.8.
;
Q:'$G(X) ""
Q:'$D(^BIREC(X,0)) ""
Q $P(^BIREC(X,0),U)
;
;
;----------
CONTXT(X) ;EP
;---> Return text of a Contraindication Reason.
;---> Parameters:
; 1 - X (req) =IEN in BI TABLE CONTRA REASON File #9002084.81.
;
Q:'$G(X) ""
Q:'$D(^BICONT(X,0)) ""
Q $P(^BICONT(X,0),U)
;
;
;----------
SKNAME(X) ;EP
;---> Return text of Skin Test name.
;---> Parameters:
; 1 - X (req) =IEN in IMMUNIZATION File #9999999.14.
;
Q:'$G(X) "NO SKIN TEST"
Q:'$D(^AUTTSK(X,0)) "UNK POINTER"
Q $P(^AUTTSK(X,0),U)
;
;
;----------
SKRESLT(X) ;EP
;---> Return text of Skin Test Result.
;---> Parameters:
; 1 - X (req) = Code for Skin Test Result.
;
Q:$G(X)="" ""
Q:X="P" "Positive"
Q:X="N" "Negative"
Q:X="D" "Doubtful"
Q:X="O" "No Take"
Q "Unknown"
;
;
;----------
HOSPLC() ;EP
;---> RETURN TEXT OF HOSPITAL LOCATION NAME.
;---> REQUIRED VARIABLE: X=IEN IN HOSPITAL LOCATION FILE #44.
Q:'$D(X) ""
Q:'X "UNKNOWN"
Q:'$D(^SC(X,0)) "UNKNOWN POINTER"
Q $P(^SC(X,0),U)
;
;
;----------
INSTIT() ;EP
;---> RETURN IEN OF INSTITUTION (FACILITY) FILE 4, FOR THIS HOSPITAL
;---> LOCATION ENTRY IN HOSPITAL LOCATION FILE 44.
;---> ALSO CONCATENATE "`" TO THE FRONT OF IEN FOR USE IN DR STRINGS.
Q:'$D(X) ""
Q:X="" ""
Q:'$D(^SC(X,0)) ""
Q:$P(^SC(X,0),U,4)']"" ""
Q "`"_$P(^SC(X,0),U,4)
;
;
;----------
INSTTX(FACILITY) ;EP
;---> Return text of Institution (Facility) Name.
;---> Parameters:
; 1 - FACILITY (req) IEN in INSTITUTION File #4.
;
Q:'$G(FACILITY) ""
Q:'$D(^DIC(4,FACILITY,0)) "Unknown facility"
Q $P(^DIC(4,FACILITY,0),U)
;
;
;----------
LOCABBR(FACILITY) ;EP
;---> Return text of Institution/Location Abbreviated Name.
;---> Parameters:
; 1 - FACILITY (req) IEN in INSTITUTION File #4.
;
Q:'$G(FACILITY) ""
Q:'$D(^AUTTLOC(FACILITY,0)) "UNKN"
Q $P(^AUTTLOC(FACILITY,0),U,7)
;
;
;----------
INSTTX1(BIVPTR,BIMX,BIIHS) ;EP
;---> Return text of Other Location if it exists (for this Visit);
;---> otherwise, return text of IHS Location.
;---> Parameters:
; 1 - BIVPTR (req) IEN of Visit in VISIT File.
; 2 - BIMX (opt) BIMX=1 to return text in mixed case.
; 3 - BIIHS (opt) BIIHS=1 to force IHS LOCATION (ignore OTHER).
; BIIHS>1 to force OTHER LOCATION.
; BIIHS<1 Look first for OTHER LOCATION;
; if null, then return IHS LOCATION.
;
Q:'$G(BIVPTR) "No Visit Pointer."
Q:'$D(^AUPNVSIT(BIVPTR,0)) "Visit does not exist."
;
N Y
S:'$G(BIMX) BIMX=0
S:'$G(BIIHS) BIIHS=0
;
D
.;---> If this Visit has an OTHER LOCATION and IHS LOCATION
.;---> is not forced, return OUTSIDE LOCATION text.
.I BIIHS<1 I $P($G(^AUPNVSIT(BIVPTR,21)),U)]"" D Q
..S Y=$P(^AUPNVSIT(BIVPTR,21),U)
.;
.;---> If OTHER LOCATION is forced, return it (even if null).
.I BIIHS>1 S Y=$P($G(^AUPNVSIT(BIVPTR,21)),U) Q
.;
.;---> If IHS Location is forced (or if neither IHS nor OTHER was
.;---> forced, but OTHER is null), return the IHS LOCATION
.;---> (.06 of VISIT File).
.S Y=$P(^AUPNVSIT(BIVPTR,0),U,6)
.I Y<1 S Y="Location not entered." Q
.S Y=$E($$INSTTX(Y),1,20)
;
Q:BIMX $$T^BITRS(Y)
Q Y
;
;
;----------
OTHERLOC(BIDUZ2,Z) ;PEP - Return IEN of the "OTHER" Location.
;---> Return IEN of the "OTHER" Location, as selected in the
;---> BI SITE PARAMETER File. (For use with Outside Locations
;---> in PCC Visit entries.)
;---> Parameters:
; 1 - BIDUZ2 (req) IEN of "OTHER" in LOCATION File.
; 2 - Z (opt) If Z=1 return text of "OTHER" Location.
;
N X S:'$G(Z) Z=0
Q:'$G(BIDUZ2) $S(Z:"OTHER NOT DEFINED",1:"")
Q:'$D(^BISITE(BIDUZ2,0)) $S(Z:"SITE PARAMETERS NOT SET.",1:"")
S X=$P(^BISITE(BIDUZ2,0),U,3)
Q:'X $S(Z:"OTHER not set in BI SITE PARAMETERS.",1:"")
Q:'$D(^DIC(4,X,0)) $S(Z:"UNKNOWN FACILITY",1:"")
Q:'Z X
Q $$INSTTX(X)
;
;
;----------
DEFPROV(BIDUZ2) ;EP
;---> Return 1 if Site Parameter says User should be the Default
;---> Provider for a new Visit.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q +$P($G(^BISITE(+$G(BIDUZ2),0)),U,16)
;
;
;----------
REPHDR(BISITE) ;EP
;---> Return text of Record/Report Header for this Site.
;---> This is the free text full name of the site as it should
;---> appear at the top of records and reports.
;---> Parameters:
; 1 - BISITE (req) IEN in BI SITE PARAMETERS File,
; the user's DUZ(2) (INSTITUTION File #4).
;
Q:'$G(BISITE) "No Facility IEN passed."
Q:'$D(^BISITE(BISITE,0)) "Report Header not set."
N X S X=$P(^BISITE(BISITE,0),U,6)
S:X="" X=$$INSTTX(BISITE)
Q X
;
;
;----------
CCTX(X) ;EP
;---> Return text of Current Community Name.
;---> Parameters:
; 1 - X (req) IEN in COMMUNITY File #9999999.05.
;
Q:'$G(X) ""
Q:'$D(^AUTTCOM(X,0)) "BAD POINTER"
Q $P(^AUTTCOM(X,0),U)
;
;
;----------
BENTX(X) ;EP
;---> Return text of Beneficiary Type.
;---> Parameters:
; 1 - X (req) IEN in BENEFICIARY File #9999999.25.
;
Q:'$G(X) ""
Q:'$D(^AUTTBEN(X,0)) "BAD POINTER"
Q $P(^AUTTBEN(X,0),U)
;
;
;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
;---> New line accounting for Event Date and Time.
;----------
IMMDTT(BIVPTR,BI012,BIFORM) ;EP
;---> Return Immunization Date and Time from V Immunizations file.
;---> If 1201 Event Date and Time field is populated, return that.
;---> Parameters:
; 1 - BIVPTR (req) IEN in VISIT File.
; 2 - BI012 (opt) 12-node of V IMM File entry.
; 3 - BIFORM (opt) Date Format: null default=MM/DD/YY, 1=(DD-Mmm-YYYY
; 2=YYYMMDD
;
N BIY D
.I $P($G(BI012),U) S BIY=$P(BI012,U) Q
.;--->
.;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
.;---> Allow return of 1201 Event or NULL, by not passing BIVPTR.
.I '$G(BIVPTR) S BIY="" Q
.;
.S BIY=$P($P($G(^AUPNVSIT($G(BIVPTR),0)),U),".")
Q:'BIY ""
;**********
Q:($G(BIFORM)=2) BIY
Q:($G(BIFORM)=1) $$TXDT1^BIUTL5(BIY,1)
Q $$SLDT2^BIUTL5(BIY,1)
;---> Old line stored in ^BIEXPDD(29,0)=S Y=$P($G(~AUPNVSIT(+BIVPTR,0)),U),Y=$$TXDT1~BIUTL5(Y,1)
;**********
;
;----------
BIUPTX(X,Y) ;EP
;---> Return text of Patient Group.
;---> Parameters:
; 1 - X (req) Code for Patient Group.
; 2 - Y (opt) If Y=1 return the long form.
;
Q:X="r" $S($G(Y):"Registered",1:"Registered Patients (All)")
Q:X="i" $S($G(Y):"Imm Register",1:"Immunization Register Patients (Active)")
Q:X="u" $S($G(Y):"User Population",1:"User Population (1 visit, 3 yrs)")
Q:X="a" $S($G(Y):"Active Users",1:"Active Users (2+ visits, 3 yrs)")
Q $S($G(Y):"Error",1:"Error (Unknown Patient Group)")
;
;
;----------
LOTTX(X,Y) ;EP
;---> Return text or vaccine of a Lot Number.
;---> Parameters:
; 1 - X (req) =IEN in IMMUNIZATION LOT File #9999999.41.
; 2 - Y (opt) If Y=1, return the Vaccine IEN associated with
; this Lot Number. If Y=2, return text of Vaccine Name.
; If Y=3 return default NDC for this Lot Number.
;
Q:'$G(X) ""
Q:'$D(^AUTTIML(X,0)) ""
;---> Return Lot Number text.
Q:'$G(Y) $P(^AUTTIML(X,0),U)
I Y=1 Q $P(^AUTTIML(X,0),U,4)
I Y=2 Q $$VNAME^BIUTL2(Z)
I Y=3 Q $P(^AUTTIML(X,0),U,17)
Q ""
;
;
;----------
DETX(X) ;EP
;---> Return text of a Data Element name.
;---> Parameters:
; 1 - X (req) =IEN in BI TABLE DATA ELEMENT File 9002084.91.
;
Q:'$G(X) ""
Q:'$D(^BIEXPDD(X,0)) ""
Q $P(^BIEXPDD(X,0),U)
;
;
;----------
TEXT1 ;EP
;;You have selected a "Duplicate Lot Number." This means that this
;;Lot Number exists at least one other time in the Lot Number file,
;;and the Immunization visit you are entering cannot be stored until
;;the duplicate has been resolved.
;;
;;Only a person with access to the Immunization Manager's Menu can
;;resolve duplicate Lot Numbers. Since you do not have this access,
;;you should contact your Immunization Program Manager or your
;;Computer Site Manager for support with this problem.
;;
;;In the meantime, you can either finish entering the Immunization
;;visit without a Lot Number, and come back to add the Lot Number to
;;this visit later, after the duplicate has been resolved.
;;Or you can simply quit without adding this visit at this time.
;;
D PRINTX("TEXT1")
Q
;
;
;----------
TEXT2 ;EP
;;You have selected a "Duplicate Lot Number." This means that this
;;Lot Number exists at least one other time in the Lot Number file,
;;and the Immunization visit you are entering cannot be stored until
;;the duplicate has been resolved.
;;
;;Two steps should be taken to resolve duplicate Lot Numbers:
;;
;;STEP 1
;;------
;;Duplicate Lot Numbers are resolved under the Manager Menu, "Lot
;;Number Add/Edit" (MGR-->LOT). Go to this option and enter the Lot
;;Number in question. Two or more choices will be presented. Select
;;one of the choices to be the valid Lot Number. Edit this Lot Number,
;;making sure it is Active and that all relevant vaccines are listed
;;under it.
D PRINTX("TEXT2")
Q
;
;
;----------
TEXT3 ;EP
;;STEP 2
;;------
;;Select and edit each of the duplicate Lot Numbers.
;;
;;Edit the Lot Number itself by placing "z" at the beginning
;;(e.g, 483-116 --> z483-116). If there is a second duplicate, add
;;"zz" to the beginning of that Lot Number; for a third duplicate,
;;add "zzz", and so on. The adding of leading "z"s to the duplicates
;;will make them distinguishable from the valid Lot Number. This
;;method will also make the old duplicate Lot Numbers recognizable on
;;pre-existing visits.
;;
;;The duplicate Lot Numbers should also be made INACTIVE.
;;If an old Visit is to be edited and it has one of the old duplicate
;;Lot Numbers, the old duplicate should be replaced with the current
;;valid Lot Number (easily recognized by ignoring the leading "z"s).
D PRINTX("TEXT3")
Q
;
;
;----------
PRINTX(BILINL,BITAB) ;EP
Q:$G(BILINL)=""
N I,T,X S T="" S:'$D(BITAB) BITAB=5 F I=1:1:BITAB S T=T_" "
F I=1:1 S X=$T(@BILINL+I) Q:X'[";;" W !,T,$P(X,";;",2)
Q
BIUTL6 ;IHS/CMI/MWR - UTIL: TEXT FOR POINTERS; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;**9**;OCT 01,2014
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; UTILITY: TEXT FOR PROVIDER, HOSP LOC, INSTIT, OTHER LOC,
+4 ;; TRANSLATIONS, REACTION, CONTRA, SITE HDR, CUR COM TXT.
+5 ;; PATCH 3: Add call to return Imm Date if 1201 Event Date is populated IMMDT
+6 ;; PATCH 9: Allow return of 1201 Event or NULL, by not passing BIVPTR. IMMDT+12
+7 ;
+8 ;
+9 ;----------
USERPOP(BIDFN,BIEDATE) ;EP - Return 1 if Patient is in User Population as of BIEDATE.
+1 ;---> Code from Lori Butcher, CMI, Feb 2010.
+2 ;---> Return 1 if Patient is in User Population; otherwise return 0.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient DFN.
+5 ; 2 - BIEDATE (req) Date as of which Patient is an in User Population.
+6 ; User Population = 1 or more qualifying visits in last 3 years.
+7 ;
+8 ;invalid patient
IF '$DATA(^AUPNPAT(BIDFN,0))
QUIT 0
+9 ;patient has no visits
IF '$DATA(^AUPNVSIT("AC",BIDFN))
QUIT 0
+10 ;
+11 NEW A,B,E,G,X,BIBDATE
+12 ;get beginning date for search, 3 yrs ago (1096 days)
SET BIBDATE=$$FMADD^XLFDT(BIEDATE,-1096)
+13 KILL ^TMP($JOB,"ALL VISITS")
+14 SET A="^TMP($J,""ALL VISITS"","
+15 SET B=BIDFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BIBDATE)_"-"_$$FMTE^XLFDT(BIEDATE)
+16 SET E=$$START1^APCLDF(B,A)
+17 IF '$DATA(^TMP($JOB,"ALL VISITS",1))
QUIT 0
+18 SET (X,UP)=0
+19 FOR
SET X=$ORDER(^TMP($JOB,"ALL VISITS",X))
IF ((X'=+X)!(UP))
QUIT
SET V=$PIECE(^TMP($JOB,"ALL VISITS",X),U,5)
Begin DoDot:1
+20 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+21 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+22 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+23 ;MUST BE A COMPLETE VISIT
IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+24 ;must be ambulatory, hosp, day surgery or obervation
IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+25 ;can't be a VA type visit
IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+26 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+27 ;has at least one visit so in user pop
SET UP=1
End DoDot:1
+28 QUIT UP
+29 ;
+30 ;
+31 ;----------
ACTCLIN(BIDFN,BIEDATE) ;EP - Return 1 if Patient is Active Clinical User as of BIEDATE.
+1 ;---> Code from Lori Butcher, CMI, Feb 2010.
+2 ;---> Return 1 if Patient is Active Clinical; otherwise return 0.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient DFN.
+5 ; 2 - BIEDATE (req) Date as of which Patient is an Active Clinical User.
+6 ; Active Clinical = 2 or more qualifying visits in last 3 years.
+7 ;
+8 ;invalid patient
IF '$DATA(^AUPNPAT(BIDFN,0))
QUIT 0
+9 ;patient has no visits
IF '$DATA(^AUPNVSIT("AC",BIDFN))
QUIT 0
+10 ;
+11 NEW A,B,E,G,X,BIBDATE,AC,S,F,BIGPRAYR
+12 ;get begin date for search, 3 yrs ago (1096 days)
SET BIBDATE=$$FMADD^XLFDT(BIEDATE,-1096)
+13 KILL ^TMP($JOB,"ALL VISITS")
+14 ;
+15 ;---> Get IEN of GPRA Control File entry.
+16 SET BIGPRAYR=$$GPRAIEN
+17 IF 'BIGPRAYR
QUIT 0
+18 ;
+19 SET A="^TMP($J,""ALL VISITS"","
+20 SET B=BIDFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BIBDATE)_"-"_$$FMTE^XLFDT(BIEDATE)
+21 SET E=$$START1^APCLDF(B,A)
+22 ;
+23 IF '$DATA(^TMP($JOB,"ALL VISITS",1))
QUIT 0
+24 SET (X,G,AC,S,F)=0
+25 FOR
SET X=$ORDER(^TMP($JOB,"ALL VISITS",X))
IF ((X'=+X)!(AC))
QUIT
SET V=$PIECE(^TMP($JOB,"ALL VISITS",X),U,5)
Begin DoDot:1
+26 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+27 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+28 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+29 ;MUST BE A COMPLETE VISIT
IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+30 ;must be ambulatory, hosp, day surgery or obervation
IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+31 ;can't be a VA type visit
IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+32 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+33 ;get clinic for active clinical check
SET B=$$CLINIC^APCLV(V,"C")
+34 IF B=""
QUIT
+35 ;must be a primary clinic
IF 'G
IF $DATA(^BGPCTRL(BIGPRAYR,11,"B",B))
SET G=V
+36 ;has a secondary type of clinic
IF V'=G
IF $DATA(^BGPCTRL(BIGPRAYR,12,"B",B))
SET S=1
+37 ;if have both then they are active clinical
IF G
IF S
SET AC=1
+38 QUIT
End DoDot:1
+39 QUIT AC
+40 ;
+41 ;
+42 ;----------
GPRAIEN() ;EP
+1 ;---> Return GPRA Control File IEN
+2 ;
+3 ;---> Get the most recent GPRA Year Control file entry.
+4 NEW BIYR,BIGPIEN
+5 SET BIYR=$ORDER(^BGPCTRL("B",""),-1)
+6 IF 'BIYR
QUIT 0
+7 SET BIGPIEN=$ORDER(^BGPCTRL("B",BIYR,0))
+8 IF 'BIGPIEN
QUIT 0
+9 IF ('$GET(^BGPCTRL(BIGPIEN,0)))
QUIT 0
+10 QUIT BIGPIEN
+11 ;
+12 ;
+13 ;----------
PROV200(X) ;EP
+1 ;---> Given PROVIDER's IEN in File #3, return the IEN in File #200.
+2 ;---> Parameters:
+3 ; 1 - X (req) =IEN in old PROVIDER File #6.
+4 ;
+5 IF '$GET(X)
QUIT ""
+6 QUIT $GET(^DIC(16,X,"A3"))
+7 ;
+8 ;
+9 ;----------
PROVIDER(X) ;EP
+1 ;---> Code to check whether to return File 6 or File 200 for
+2 ;---> Provider. ** Not used so far. **
+3 ;
+4 IF 'X
QUIT ""
+5 ;---> IF PCC WANTS A FILE 6 POINTER FOR PROVIDER, RESET X.
+6 IF '$PIECE(^AUTTSITE(1,0),U,22)
Begin DoDot:1
+7 IF $PIECE($GET(^VA(200,X,0)),U,16)
SET X=$PIECE(^(0),U,16)
QUIT
+8 SET X=$PIECE($GET(^DIC(3,X,0)),U,16)
End DoDot:1
+9 QUIT X
+10 ;
+11 ;
+12 ;----------
REACTXT(X) ;EP
+1 ;---> Return text of Reaction to Immunization.
+2 ;---> Parameters:
+3 ; 1 - X (req) =IEN in IMMUNIZATION File #9002084.8.
+4 ;
+5 IF '$GET(X)
QUIT ""
+6 IF '$DATA(^BIREC(X,0))
QUIT ""
+7 QUIT $PIECE(^BIREC(X,0),U)
+8 ;
+9 ;
+10 ;----------
CONTXT(X) ;EP
+1 ;---> Return text of a Contraindication Reason.
+2 ;---> Parameters:
+3 ; 1 - X (req) =IEN in BI TABLE CONTRA REASON File #9002084.81.
+4 ;
+5 IF '$GET(X)
QUIT ""
+6 IF '$DATA(^BICONT(X,0))
QUIT ""
+7 QUIT $PIECE(^BICONT(X,0),U)
+8 ;
+9 ;
+10 ;----------
SKNAME(X) ;EP
+1 ;---> Return text of Skin Test name.
+2 ;---> Parameters:
+3 ; 1 - X (req) =IEN in IMMUNIZATION File #9999999.14.
+4 ;
+5 IF '$GET(X)
QUIT "NO SKIN TEST"
+6 IF '$DATA(^AUTTSK(X,0))
QUIT "UNK POINTER"
+7 QUIT $PIECE(^AUTTSK(X,0),U)
+8 ;
+9 ;
+10 ;----------
SKRESLT(X) ;EP
+1 ;---> Return text of Skin Test Result.
+2 ;---> Parameters:
+3 ; 1 - X (req) = Code for Skin Test Result.
+4 ;
+5 IF $GET(X)=""
QUIT ""
+6 IF X="P"
QUIT "Positive"
+7 IF X="N"
QUIT "Negative"
+8 IF X="D"
QUIT "Doubtful"
+9 IF X="O"
QUIT "No Take"
+10 QUIT "Unknown"
+11 ;
+12 ;
+13 ;----------
HOSPLC() ;EP
+1 ;---> RETURN TEXT OF HOSPITAL LOCATION NAME.
+2 ;---> REQUIRED VARIABLE: X=IEN IN HOSPITAL LOCATION FILE #44.
+3 IF '$DATA(X)
QUIT ""
+4 IF 'X
QUIT "UNKNOWN"
+5 IF '$DATA(^SC(X,0))
QUIT "UNKNOWN POINTER"
+6 QUIT $PIECE(^SC(X,0),U)
+7 ;
+8 ;
+9 ;----------
INSTIT() ;EP
+1 ;---> RETURN IEN OF INSTITUTION (FACILITY) FILE 4, FOR THIS HOSPITAL
+2 ;---> LOCATION ENTRY IN HOSPITAL LOCATION FILE 44.
+3 ;---> ALSO CONCATENATE "`" TO THE FRONT OF IEN FOR USE IN DR STRINGS.
+4 IF '$DATA(X)
QUIT ""
+5 IF X=""
QUIT ""
+6 IF '$DATA(^SC(X,0))
QUIT ""
+7 IF $PIECE(^SC(X,0),U,4)']""
QUIT ""
+8 QUIT "`"_$PIECE(^SC(X,0),U,4)
+9 ;
+10 ;
+11 ;----------
INSTTX(FACILITY) ;EP
+1 ;---> Return text of Institution (Facility) Name.
+2 ;---> Parameters:
+3 ; 1 - FACILITY (req) IEN in INSTITUTION File #4.
+4 ;
+5 IF '$GET(FACILITY)
QUIT ""
+6 IF '$DATA(^DIC(4,FACILITY,0))
QUIT "Unknown facility"
+7 QUIT $PIECE(^DIC(4,FACILITY,0),U)
+8 ;
+9 ;
+10 ;----------
LOCABBR(FACILITY) ;EP
+1 ;---> Return text of Institution/Location Abbreviated Name.
+2 ;---> Parameters:
+3 ; 1 - FACILITY (req) IEN in INSTITUTION File #4.
+4 ;
+5 IF '$GET(FACILITY)
QUIT ""
+6 IF '$DATA(^AUTTLOC(FACILITY,0))
QUIT "UNKN"
+7 QUIT $PIECE(^AUTTLOC(FACILITY,0),U,7)
+8 ;
+9 ;
+10 ;----------
INSTTX1(BIVPTR,BIMX,BIIHS) ;EP
+1 ;---> Return text of Other Location if it exists (for this Visit);
+2 ;---> otherwise, return text of IHS Location.
+3 ;---> Parameters:
+4 ; 1 - BIVPTR (req) IEN of Visit in VISIT File.
+5 ; 2 - BIMX (opt) BIMX=1 to return text in mixed case.
+6 ; 3 - BIIHS (opt) BIIHS=1 to force IHS LOCATION (ignore OTHER).
+7 ; BIIHS>1 to force OTHER LOCATION.
+8 ; BIIHS<1 Look first for OTHER LOCATION;
+9 ; if null, then return IHS LOCATION.
+10 ;
+11 IF '$GET(BIVPTR)
QUIT "No Visit Pointer."
+12 IF '$DATA(^AUPNVSIT(BIVPTR,0))
QUIT "Visit does not exist."
+13 ;
+14 NEW Y
+15 IF '$GET(BIMX)
SET BIMX=0
+16 IF '$GET(BIIHS)
SET BIIHS=0
+17 ;
+18 Begin DoDot:1
+19 ;---> If this Visit has an OTHER LOCATION and IHS LOCATION
+20 ;---> is not forced, return OUTSIDE LOCATION text.
+21 IF BIIHS<1
IF $PIECE($GET(^AUPNVSIT(BIVPTR,21)),U)]""
Begin DoDot:2
+22 SET Y=$PIECE(^AUPNVSIT(BIVPTR,21),U)
End DoDot:2
QUIT
+23 ;
+24 ;---> If OTHER LOCATION is forced, return it (even if null).
+25 IF BIIHS>1
SET Y=$PIECE($GET(^AUPNVSIT(BIVPTR,21)),U)
QUIT
+26 ;
+27 ;---> If IHS Location is forced (or if neither IHS nor OTHER was
+28 ;---> forced, but OTHER is null), return the IHS LOCATION
+29 ;---> (.06 of VISIT File).
+30 SET Y=$PIECE(^AUPNVSIT(BIVPTR,0),U,6)
+31 IF Y<1
SET Y="Location not entered."
QUIT
+32 SET Y=$EXTRACT($$INSTTX(Y),1,20)
End DoDot:1
+33 ;
+34 IF BIMX
QUIT $$T^BITRS(Y)
+35 QUIT Y
+36 ;
+37 ;
+38 ;----------
OTHERLOC(BIDUZ2,Z) ;PEP - Return IEN of the "OTHER" Location.
+1 ;---> Return IEN of the "OTHER" Location, as selected in the
+2 ;---> BI SITE PARAMETER File. (For use with Outside Locations
+3 ;---> in PCC Visit entries.)
+4 ;---> Parameters:
+5 ; 1 - BIDUZ2 (req) IEN of "OTHER" in LOCATION File.
+6 ; 2 - Z (opt) If Z=1 return text of "OTHER" Location.
+7 ;
+8 NEW X
IF '$GET(Z)
SET Z=0
+9 IF '$GET(BIDUZ2)
QUIT $SELECT(Z:"OTHER NOT DEFINED",1:"")
+10 IF '$DATA(^BISITE(BIDUZ2,0))
QUIT $SELECT(Z:"SITE PARAMETERS NOT SET.",1:"")
+11 SET X=$PIECE(^BISITE(BIDUZ2,0),U,3)
+12 IF 'X
QUIT $SELECT(Z:"OTHER not set in BI SITE PARAMETERS.",1:"")
+13 IF '$DATA(^DIC(4,X,0))
QUIT $SELECT(Z:"UNKNOWN FACILITY",1:"")
+14 IF 'Z
QUIT X
+15 QUIT $$INSTTX(X)
+16 ;
+17 ;
+18 ;----------
DEFPROV(BIDUZ2) ;EP
+1 ;---> Return 1 if Site Parameter says User should be the Default
+2 ;---> Provider for a new Visit.
+3 ;---> Parameters:
+4 ; 1 - BIDUZ2 (req) User's DUZ(2)
+5 ;
+6 QUIT +$PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,16)
+7 ;
+8 ;
+9 ;----------
REPHDR(BISITE) ;EP
+1 ;---> Return text of Record/Report Header for this Site.
+2 ;---> This is the free text full name of the site as it should
+3 ;---> appear at the top of records and reports.
+4 ;---> Parameters:
+5 ; 1 - BISITE (req) IEN in BI SITE PARAMETERS File,
+6 ; the user's DUZ(2) (INSTITUTION File #4).
+7 ;
+8 IF '$GET(BISITE)
QUIT "No Facility IEN passed."
+9 IF '$DATA(^BISITE(BISITE,0))
QUIT "Report Header not set."
+10 NEW X
SET X=$PIECE(^BISITE(BISITE,0),U,6)
+11 IF X=""
SET X=$$INSTTX(BISITE)
+12 QUIT X
+13 ;
+14 ;
+15 ;----------
CCTX(X) ;EP
+1 ;---> Return text of Current Community Name.
+2 ;---> Parameters:
+3 ; 1 - X (req) IEN in COMMUNITY File #9999999.05.
+4 ;
+5 IF '$GET(X)
QUIT ""
+6 IF '$DATA(^AUTTCOM(X,0))
QUIT "BAD POINTER"
+7 QUIT $PIECE(^AUTTCOM(X,0),U)
+8 ;
+9 ;
+10 ;----------
BENTX(X) ;EP
+1 ;---> Return text of Beneficiary Type.
+2 ;---> Parameters:
+3 ; 1 - X (req) IEN in BENEFICIARY File #9999999.25.
+4 ;
+5 IF '$GET(X)
QUIT ""
+6 IF '$DATA(^AUTTBEN(X,0))
QUIT "BAD POINTER"
+7 QUIT $PIECE(^AUTTBEN(X,0),U)
+8 ;
+9 ;
+10 ;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
+11 ;---> New line accounting for Event Date and Time.
+12 ;----------
IMMDTT(BIVPTR,BI012,BIFORM) ;EP
+1 ;---> Return Immunization Date and Time from V Immunizations file.
+2 ;---> If 1201 Event Date and Time field is populated, return that.
+3 ;---> Parameters:
+4 ; 1 - BIVPTR (req) IEN in VISIT File.
+5 ; 2 - BI012 (opt) 12-node of V IMM File entry.
+6 ; 3 - BIFORM (opt) Date Format: null default=MM/DD/YY, 1=(DD-Mmm-YYYY
+7 ; 2=YYYMMDD
+8 ;
+9 NEW BIY
Begin DoDot:1
+10 IF $PIECE($GET(BI012),U)
SET BIY=$PIECE(BI012,U)
QUIT
+11 ;--->
+12 ;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
+13 ;---> Allow return of 1201 Event or NULL, by not passing BIVPTR.
+14 IF '$GET(BIVPTR)
SET BIY=""
QUIT
+15 ;
+16 SET BIY=$PIECE($PIECE($GET(^AUPNVSIT($GET(BIVPTR),0)),U),".")
End DoDot:1
+17 IF 'BIY
QUIT ""
+18 ;**********
+19 IF ($GET(BIFORM)=2)
QUIT BIY
+20 IF ($GET(BIFORM)=1)
QUIT $$TXDT1^BIUTL5(BIY,1)
+21 QUIT $$SLDT2^BIUTL5(BIY,1)
+22 ;---> Old line stored in ^BIEXPDD(29,0)=S Y=$P($G(~AUPNVSIT(+BIVPTR,0)),U),Y=$$TXDT1~BIUTL5(Y,1)
+23 ;**********
+24 ;
+25 ;----------
BIUPTX(X,Y) ;EP
+1 ;---> Return text of Patient Group.
+2 ;---> Parameters:
+3 ; 1 - X (req) Code for Patient Group.
+4 ; 2 - Y (opt) If Y=1 return the long form.
+5 ;
+6 IF X="r"
QUIT $SELECT($GET(Y):"Registered",1:"Registered Patients (All)")
+7 IF X="i"
QUIT $SELECT($GET(Y):"Imm Register",1:"Immunization Register Patients (Active)")
+8 IF X="u"
QUIT $SELECT($GET(Y):"User Population",1:"User Population (1 visit, 3 yrs)")
+9 IF X="a"
QUIT $SELECT($GET(Y):"Active Users",1:"Active Users (2+ visits, 3 yrs)")
+10 QUIT $SELECT($GET(Y):"Error",1:"Error (Unknown Patient Group)")
+11 ;
+12 ;
+13 ;----------
LOTTX(X,Y) ;EP
+1 ;---> Return text or vaccine of a Lot Number.
+2 ;---> Parameters:
+3 ; 1 - X (req) =IEN in IMMUNIZATION LOT File #9999999.41.
+4 ; 2 - Y (opt) If Y=1, return the Vaccine IEN associated with
+5 ; this Lot Number. If Y=2, return text of Vaccine Name.
+6 ; If Y=3 return default NDC for this Lot Number.
+7 ;
+8 IF '$GET(X)
QUIT ""
+9 IF '$DATA(^AUTTIML(X,0))
QUIT ""
+10 ;---> Return Lot Number text.
+11 IF '$GET(Y)
QUIT $PIECE(^AUTTIML(X,0),U)
+12 IF Y=1
QUIT $PIECE(^AUTTIML(X,0),U,4)
+13 IF Y=2
QUIT $$VNAME^BIUTL2(Z)
+14 IF Y=3
QUIT $PIECE(^AUTTIML(X,0),U,17)
+15 QUIT ""
+16 ;
+17 ;
+18 ;----------
DETX(X) ;EP
+1 ;---> Return text of a Data Element name.
+2 ;---> Parameters:
+3 ; 1 - X (req) =IEN in BI TABLE DATA ELEMENT File 9002084.91.
+4 ;
+5 IF '$GET(X)
QUIT ""
+6 IF '$DATA(^BIEXPDD(X,0))
QUIT ""
+7 QUIT $PIECE(^BIEXPDD(X,0),U)
+8 ;
+9 ;
+10 ;----------
TEXT1 ;EP
+1 ;;You have selected a "Duplicate Lot Number." This means that this
+2 ;;Lot Number exists at least one other time in the Lot Number file,
+3 ;;and the Immunization visit you are entering cannot be stored until
+4 ;;the duplicate has been resolved.
+5 ;;
+6 ;;Only a person with access to the Immunization Manager's Menu can
+7 ;;resolve duplicate Lot Numbers. Since you do not have this access,
+8 ;;you should contact your Immunization Program Manager or your
+9 ;;Computer Site Manager for support with this problem.
+10 ;;
+11 ;;In the meantime, you can either finish entering the Immunization
+12 ;;visit without a Lot Number, and come back to add the Lot Number to
+13 ;;this visit later, after the duplicate has been resolved.
+14 ;;Or you can simply quit without adding this visit at this time.
+15 ;;
+16 DO PRINTX("TEXT1")
+17 QUIT
+18 ;
+19 ;
+20 ;----------
TEXT2 ;EP
+1 ;;You have selected a "Duplicate Lot Number." This means that this
+2 ;;Lot Number exists at least one other time in the Lot Number file,
+3 ;;and the Immunization visit you are entering cannot be stored until
+4 ;;the duplicate has been resolved.
+5 ;;
+6 ;;Two steps should be taken to resolve duplicate Lot Numbers:
+7 ;;
+8 ;;STEP 1
+9 ;;------
+10 ;;Duplicate Lot Numbers are resolved under the Manager Menu, "Lot
+11 ;;Number Add/Edit" (MGR-->LOT). Go to this option and enter the Lot
+12 ;;Number in question. Two or more choices will be presented. Select
+13 ;;one of the choices to be the valid Lot Number. Edit this Lot Number,
+14 ;;making sure it is Active and that all relevant vaccines are listed
+15 ;;under it.
+16 DO PRINTX("TEXT2")
+17 QUIT
+18 ;
+19 ;
+20 ;----------
TEXT3 ;EP
+1 ;;STEP 2
+2 ;;------
+3 ;;Select and edit each of the duplicate Lot Numbers.
+4 ;;
+5 ;;Edit the Lot Number itself by placing "z" at the beginning
+6 ;;(e.g, 483-116 --> z483-116). If there is a second duplicate, add
+7 ;;"zz" to the beginning of that Lot Number; for a third duplicate,
+8 ;;add "zzz", and so on. The adding of leading "z"s to the duplicates
+9 ;;will make them distinguishable from the valid Lot Number. This
+10 ;;method will also make the old duplicate Lot Numbers recognizable on
+11 ;;pre-existing visits.
+12 ;;
+13 ;;The duplicate Lot Numbers should also be made INACTIVE.
+14 ;;If an old Visit is to be edited and it has one of the old duplicate
+15 ;;Lot Numbers, the old duplicate should be replaced with the current
+16 ;;valid Lot Number (easily recognized by ignoring the leading "z"s).
+17 DO PRINTX("TEXT3")
+18 QUIT
+19 ;
+20 ;
+21 ;----------
PRINTX(BILINL,BITAB) ;EP
+1 IF $GET(BILINL)=""
QUIT
+2 NEW I,T,X
SET T=""
IF '$DATA(BITAB)
SET BITAB=5
FOR I=1:1:BITAB
SET T=T_" "
+3 FOR I=1:1
SET X=$TEXT(@BILINL+I)
IF X'[";;"
QUIT
WRITE !,T,$PIECE(X,";;",2)
+4 QUIT
