Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BJPC1EC1

BJPC1EC1.m

Go to the documentation of this file. 
  1. BJPC1EC1 ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check [ 04/10/2008  9:01 AM ]
  1.  ;;1.0;IHS PCC SUITE;**1**;MAR 14, 2008
  1.  ;
  1.  ;
  1.  ; The following line prevents the "Disable Options..." and "Move
  1.  ; Routines..." questions from being asked during the install.
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  I '$$INSTALLD("ATX*5.1*10") D SORRY(2)
  1.  I '$$INSTALLD("AUPN*99.1*18") D SORRY(2)
  1.  I '$$INSTALLD("APCD*2.0*10") D SORRY(2)
  1.  I '$$INSTALLD("APCL*3.0*21") D SORRY(2)
  1.  I '$$INSTALLD("APCH*2.0*17") D SORRY(2)
  1.  I '$$INSTALLD("BDP*1.0*1") D SORRY(2)
  1.  I '$$INSTALLD("AMQQ*2.0*20") D SORRY(2)
  1.  I '$D(^DIC(9.4,"C","LEX")) D MES^XPDUTL($$CJ^XLFSTR("Lexicon is *NOT* installed.",IOM)) D SORRY(2)
  1.  ;
  1.  Q
  1.  ;
  1. PRE ;
  1.  S BJPCX=0 F  S BJPCX=$O(^APCLCNTL(BJPCX)) Q:BJPCX'=+BJPCX  S DA=BJPCX,DIK="^APCLCNTL(" D ^DIK
  1.  F DA=1:1:900 S DIK="^APCLVSTS(" D ^DIK
  1.  S BJPCX=0 F  S BJPCX=$O(^APCLDMTX(BJPCX)) Q:BJPCX'=+BJPCX  S DA=BJPCX,DIK="^APCLDMTX(" D ^DIK
  1. AS ;get rid of FEV1, FV1P
  1.  F BJPCMR="FEV1","FV1P","FVC","FVCP" S BJPCM=$O(^AUTTMSR("B",BJPCMR,0)) I BJPCM D
  1.  .S BJPCDA=0 F  S BJPCDA=$O(^AUPNVMSR("B",BJPCM,BJPCDA)) Q:BJPCDA'=+BJPCDA  S DA=BJPCDA,DIK="^AUPNVMSR(" D ^DIK
  1.  .S DA=BJPCM,DIK="^AUTTMSR(" D ^DIK
  1.  F BJPCMR="FEV1","FV1P","FVC","FVCP" S BJPCM=$O(^APCDTKW("B",BJPCMR,0)) I BJPCM S DA=BJPCM,DIK="^APCDTKW(" D ^DIK
  1.  ;STUFF ALL EXISTING REMINDERS WITH R
  1.  S BJPCX=0 F  S BJPCX=$O(^APCHSURV(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P(^APCHSURV(BJPCX,0),U,7)]""
  1.  .Q:$P(^APCHSURV(BJPCX,0),U,7)="T"
  1.  .S $P(^APCHSURV(BJPCX,0),U,7)="R"
  1.  S DA=$O(^APCHSURV("B","ASTHMA - ADD/INCREASE INHALED ",0))
  1.  I DA S DIE="^APCHSURV(",DR=".01///ASTHMA - ADD/INCREASE INHALED STEROIDS" D ^DIE K DA,DIE
  1.  Q
  1. POST ;
  1.  ;;add new clinic code telebehavioral health
  1.  NEW DA,DIC,DR,DIE
  1.  S DA=$O(^DIC(40.7,"C","C9",0)) I 'DA D
  1.  .S DLAYGO=40.7,DIC(0)="L",DIC="^DIC(40.7,",X="TELEBEHAVIORAL HEALTH"
  1.  .K DD,D0,DO
  1.  .D FILE^DICN
  1.  .I Y=-1 D MES^XPDUTL($$CJ^XLFSTR("Adding Clinic TELEBEHAVIORAL HEALTH Failed.",IOM))
  1.  .S DA=+Y
  1.  .K DLAYGO,DIC,Y
  1.  I DA D
  1.  .S DIE="^DIC(40.7,",DR="1///C9;999999901///TEBH;90000.01///Y"
  1.  .D ^DIE
  1.  .I $D(Y) D MES^XPDUTL($$CJ^XLFSTR("Updating Clinic TELEBEHAVIORAL HEALTH Failed.",IOM))
  1.  K DA,DR,DIE
  1. OPTIONS ;
  1.  S X=$$ADD^XPDMENU("APCDCAF EHR CODING AUDIT MENU","APCDCAF LIST INCOMPLETE","INCV")
  1.  I 'X W "Attempt to add coding queue incomplete visit option failed." H 3
  1.  S X=$$ADD^XPDMENU("APCHSMAINT","APCH TREATMENT PROMPT MENU","TP")
  1.  I 'X W "Attempt to add coding queue incomplete visit option failed." H 3
  1.  ;
  1. ASAMP ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Management Plan to V Patient Education.",IOM))
  1.  S BJPCIEN=$O(^AUTTEDT("C","ASM-SMP",0))
  1.  I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASM-SMP education topic missing from file, cannot move data.",IOM)) G ASTRIGET
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,12)=""  ;no asthma management plan to copy
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,12)'=1
  1.  .Q:$$HASASAMP($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
  1.  .S APCDALVR("APCDTTOP")="`"_BJPCIEN
  1.  .S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
  1.  .D ^APCDALVR
  1.  .I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Patient ed ASM-SMP failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
  1.  .K APCDALVR
  1. ASTRIGET ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger ETS to V Health Factors.",IOM))
  1.  S BJPCIEN=$O(^AUTTHF("B","ASTHMA TRIGGER-TOBACCO SMOKE",0))
  1.  I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGER-TOBACCO SMOKE missing from file, cannot move data.",IOM)) G ASTRIGPM
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,8)'="Y"  ;no asthma management plan to copy
  1.  .Q:$$HASASHF($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
  1.  .S APCDALVR("APCDTHF")="`"_BJPCIEN
  1.  .S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
  1.  .S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
  1.  .D ^APCDALVR
  1.  .I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGERS-TOBACCO SMOKE failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
  1.  .K APCDALVR
  1. ASTRIGPM ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger AIR POLLUTANTS to V Health Factors.",IOM))
  1.  S BJPCIEN=$O(^AUTTHF("B","ASTHMA TRIGGER-AIR POLLUTANTS",0))
  1.  I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGER-AIR POLLUTANTS missing from file, cannot move data.",IOM)) G ASTRIGDM
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,9)'="Y"
  1.  .Q:$$HASASHF($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
  1.  .S APCDALVR("APCDTHF")="`"_BJPCIEN
  1.  .S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
  1.  .S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
  1.  .D ^APCDALVR
  1.  .I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGERS-AIR POLLUTANTS failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
  1.  .K APCDALVR
  1. ASTRIGDM ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger DUST MITES to V Health Factors.",IOM))
  1.  S BJPCIEN=$O(^AUTTHF("B","ASTHMA TRIGGER-DUST MITES",0))
  1.  I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGERS-DUST MITES missing from file, cannot move data.",IOM)) G ASMEAPEF
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,11)'="Y"
  1.  .Q:$$HASASHF($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
  1.  .S APCDALVR("APCDTHF")="`"_BJPCIEN
  1.  .S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
  1.  .S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
  1.  .D ^APCDALVR
  1.  .I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGER-DUST MITES failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
  1.  .K APCDALVR
  1. ASMEAPEF ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying PEF/BEST PF to V Measurements.",IOM))
  1.  S BJPCIEN=$O(^AUTTMSR("B","BPF",0))
  1.  I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("BPF missing from file, cannot move data.",IOM)) G ASMEAFEF
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,7)=""
  1.  .Q:$$HASASME($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
  1.  .S APCDALVR("APCDTTYP")="`"_BJPCIEN
  1.  .S APCDALVR("APCDTVAL")=$P(^AUPNVAST(BJPCX,0),U,7)
  1.  .S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
  1.  .S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
  1.  .D ^APCDALVR
  1.  .I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Measurement BPF failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
  1.  .K APCDALVR
  1. ASMEAFEF ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying FEF 25-75 to V Measurements.",IOM))
  1.  S BJPCIEN=$O(^AUTTMSR("B","FEF",0))
  1.  I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("FEF missing from file, cannot move data.",IOM)) G ASMEAFEV
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,6)=""
  1.  .Q:$$HASASME($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
  1.  .S APCDALVR("APCDTTYP")="`"_BJPCIEN
  1.  .S APCDALVR("APCDTVAL")=$P(^AUPNVAST(BJPCX,0),U,6)
  1.  .S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
  1.  .S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
  1.  .D ^APCDALVR
  1.  .I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Measurement FEF 25-75 failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
  1.  .K APCDALVR
  1. ASMEAFEV ;
  1.  G NEXT
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying Fev1 % to V Measurements.",IOM))
  1.  S BJPCIEN=$O(^AUTTMSR("B","FV1P",0))
  1.  I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("FV1P missing from file, cannot move data.",IOM)) G NEXT
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P($G(^AUPNVAST(BJPCX,0)),U,5)=""
  1.  .Q:$$HASASME($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
  1.  .K APCDALVR
  1.  .S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
  1.  .S APCDALVR("APCDTTYP")="`"_BJPCIEN
  1.  .S APCDALVR("APCDTVAL")=$P(^AUPNVAST(BJPCX,0),U,5)
  1.  .S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
  1.  .S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
  1.  .D ^APCDALVR
  1.  .I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Measurement FEV 1% failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
  1.  .K APCDALVR
  1. NEXT ;
  1.  ;FIX FH 8TH PIECE
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNFH(BJPCX)) Q:BJPCX'=+BJPCX  I '$P(^AUPNFH(BJPCX,0),U,8) S $P(^AUPNFH(BJPCX,0),U,8)=""
  1.  ;
  1. MOVEFH ;move Family History problem entries to fh
  1.  D MES^XPDUTL($$CJ^XLFSTR("Copying Family History Problem entries to Family History.",IOM))
  1.  S BJPCX=0 F  S BJPCX=$O(^AUPNPROB(BJPCX)) Q:BJPCX'=+BJPCX  D
  1.  .Q:$P(^AUPNPROB(BJPCX,0),U,4)'="F"
  1.  .;CREATE FAMILY HX ENTRY
  1.  .S P=$P(^AUPNPROB(BJPCX,0),U,2)
  1.  .Q:'P
  1.  .S X=$P(^AUPNPROB(BJPCX,0),U)
  1.  .Q:'X
  1.  .S N=$P(^AUPNPROB(BJPCX,0),U,5)
  1.  .I '$$HASFH(P,X,N) D
  1.  ..S DIC="^AUPNFH("
  1.  ..S DLAYGO=9000014
  1.  ..S DIADD=1
  1.  ..S DIC("DR")=".02////"_P_";.03////"_$P(^AUPNPROB(BJPCX,0),U,8)_";.04////"_N_";.08////"_$P($G(^AUPNPROB(1,1)),U,4)
  1.  ..S DIC(0)="L"
  1.  ..K DD,D0,DO
  1.  ..D FILE^DICN
  1.  ..I Y=-1 D MES^XPDUTL("Error creating family history entry for problem entry "_BJPCX) K DIC,DIADD,DLAYGO Q
  1.  ..K DIC,DIADD,DLAYGO
  1.  ..;S DA=BJPCX,DIK="^AUPNPROB(" D ^DIK K DA,DIK  DO NOT DELETE PER HOWARD ON CCB CALL 1/31/08
  1.  ..Q
  1. DELAST ;
  1.  ;delete ast and hast mnemonics
  1.  S DA=$O(^APCDTKW("B","AST",0)) I DA S DIK="^APCDTKW(" D ^DIK
  1.  S DA=$O(^APCDTKW("B","HAST",0)) I DA S DIK="^APCDTKW(" D ^DIK
  1.  ;
  1.  ;now "delete" anmc reminders
  1.  S DA=$O(^APCHSURV("B","ANMC COLORECTAL",0))
  1.  I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
  1.  S DA=$O(^APCHSURV("B","ANMC COLORECTAL CANCER",0))
  1.  I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
  1.  S DA=$O(^APCHSURV("B","ANMC DEPRESSION SCREEN",0))
  1.  I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
  1.  S DA=$O(^APCHSURV("B","REHAB/FUNCTIONAL SCREEN",0))
  1.  I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
  1.  ;
  1.  D ^BJPCTX
  1.  D ^BJPC1ECA
  1.  S DA=$O(^APCDSTGC("B","DIABETIC RETINOPATHY",0))
  1.  I DA S DIE="^APCDSTGC(",DR=".02///APCD DIABETIC RETINOPATHY DXS" D ^DIE K DA,DIE
  1.  ;
  1.  D HOME^%ZIS,DT^DICRW
  1.  ;
  1.  NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
  1.  KILL ^TMP($J,"BJPCBUL")
  1.  D WRITEMSG,GETRECIP
  1.  ;Change following lines as desired
  1. SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
  1. SENDER S XMDUZ="Cimarron Medical Informatics"
  1.  S XMTEXT="^TMP($J,""BJPCBUL"",",XMY(1)="",XMY(DUZ)=""
  1.  I $E(IOST)="C" W !,"Sending Mailman message to PCC Users."
  1.  D ^XMD
  1.  KILL ^TMP($J,"BJPCBUL"),BJPCKEY
  1.  Q
  1.  ;
  1. WRITEMSG ;
  1.  S X=$O(^APCLPDES("B","BJPCV1P1",0))
  1.  Q:'X
  1.  S Y=0 F  S Y=$O(^APCLPDES(X,11,Y)) Q:Y'=+Y  S ^TMP($J,"BJPCBUL",Y)=^APCLPDES(X,11,Y,0)
  1.  Q
  1.  ;
  1. GETRECIP ;
  1.  ;
  1.  S CTR=0
  1.  F BJPCKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
  1.  F  S CTR=$O(^XUSEC(BJPCKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""
  1.  Q
  1. INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
  1.  ; APCLSTAL is the name of the INSTALL.  E.g "AG*6.0*11".
  1.  ;
  1.  NEW BJPCY,DIC,X,Y
  1.  S X=$P(BJPCSTAL,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",22,",X=$P(BJPCSTAL,"*",2)
  1.  D ^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(BJPCSTAL,"*",3)
  1.  D ^DIC
  1.  S BJPCY=Y
  1.  D IMES
  1.  Q $S(BJPCY<1:0,1:1)
  1. IMES ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
  1.  Q
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  I X=3 S XPDQUIT=2 Q
  1.  S XPDQUIT=X
  1.  W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
  1.  Q
  1.  ;
  1. CLINNEW ;;H. NEW CLINIC CODES (SECTION XIX): CODE^NAME^ABBRV^PRIMARY CARE CLINIC^1A WORKLOAD
  1.  ;;C8^TELEBEHAVIORAL HEALTH^TEBH^N^Y
  1.  ;;END
  1.  ;
  1. HASASAMP(V,I) ;is there a v patient ed of ASM-SMP?
  1.  NEW X,Y,Z
  1.  S (X,Z)=0 F  S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X  D
  1.  .I $P($G(^AUPNVPED(X,0)),U)=I S Z=1
  1.  .Q
  1.  Q Z
  1.  ;
  1. HASASHF(V,I) ;
  1.  NEW X,Y,Z
  1.  S (X,Z)=0 F  S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X  D
  1.  .I $P($G(^AUPNVHF(X,0)),U)=I S Z=1
  1.  .Q
  1.  Q Z
  1.  ;
  1. HASASME(V,I) ;is there a v MEASUREMENT I?
  1.  NEW X,Y,Z
  1.  S (X,Z)=0 F  S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X  D
  1.  .I $P($G(^AUPNVMSR(X,0)),U)=I S Z=1
  1.  .Q
  1.  Q Z
  1.  ;
  1. HASFH(P,I,N) ;
  1.  NEW X,Y,Z
  1.  S (X,Z)=0 F  S X=$O(^AUPNFH("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNFH(X,0))
  1.  .I $P(^AUPNFH(X,0),U,1)=I,$P(^AUPNFH(X,0),U,4)=N S Z=1
  1.  .Q
  1.  Q Z
  1.  ;