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

APCDHIST.m

Go to the documentation of this file. 
  1. APCDHIST ; IHS/CMI/LAB - DISPLAY HIST. DATA ;
  1.  ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
  1.  ;
  1. DATE S APCDTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))" K Y
  1.  Q
  1. FMH ; ******************** FAMILY HISTORY * 9000014 *******
  1.  D DATE
  1.  S APCDTICF="S"
  1.  ; <SETUP>
  1.  I '$D(^AUPNFH("AC",APCDPAT)) W !!,"******************* NO FAMILY HISTORY ON FILE **********************" Q
  1.  W !!,"****************** FAMILY HISTORY ******************",!!
  1.  ; <DISPLAY>
  1.  S APCDTDFN="" F APCDTQ=0:0 S APCDTDFN=$O(^AUPNFH("AC",APCDPAT,APCDTDFN)) Q:APCDTDFN=""  D FHDSP
  1.  ; <CLEANUP>
  1. FMHX K APCDTDFN,APCDTN,APCDTICD,APCDTDAT,APCDTNRQ,APCDTICL,APCDTNQ,APCDTICF,APCDTCVD,APCDTQ,Y
  1.  Q
  1. FHDSP S APCDTN=^AUPNFH(APCDTDFN,0)
  1.  S APCDTICD=$P(APCDTN,U) D GETICDDX
  1.  S Y=$P(APCDTN,U,3) X APCDTCVD S APCDTDAT=Y
  1.  S APCDTNRQ=$$VAL^XBDIQ1(9000014,APCDTDFN,.04)
  1.  D GETNARR
  1.  W APCDTDAT S APCDTICL=12
  1.  NEW X,R,S,A,P
  1.  S (X,R,S,N,A,P)=""
  1.  S R=$$VAL^XBDIQ1(9000014,APCDTDFN,.07)
  1.  S N=$$VAL^XBDIQ1(9000014,APCDTDFN,.04)_" ("_$$VAL^XBDIQ1(9000014,APCDTDFN,.01)_")"
  1.  S A=$P(^AUPNFH(APCDTDFN,0),U,5)
  1.  S S=$$VAL^XBDIQ1(9000014,APCDTDFN,.06)
  1.  S P=$$VAL^XBDIQ1(9000014,APCDTDFN,.08)
  1.  S X=R
  1.  I X]"" S X=X_"; "
  1.  S X=X_N
  1.  S X=X_$S(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
  1.  S X=X_$S(S]"":"; Status: "_S,1:"; Status: None")
  1.  S X=X_$S(P]"":"; Documented By: "_P,1:"")
  1.  S APCDTICL=12,APCDTNRQ=X,APCDTICD=""
  1.  D PRTICD
  1.  Q
  1.  ;
  1. PMH ; ******************** PERSONAL HISTORY * 9000013 *******
  1.  ; <SETUP>
  1.  D DATE
  1.  S APCDTICF="S"
  1.  ; <SETUP>
  1.  I '$D(^AUPNPH("AC",APCDPAT)) W !!,"******************* NO PERSONAL HISTORY ON FILE **********************" Q
  1.  ; <DISPLAY>
  1.  W !!,"********************** PERSONAL HISTORY ********************",!!
  1.  S APCDTDFN="" F APCDTQ=0:0 S APCDTDFN=$O(^AUPNPH("AC",APCDPAT,APCDTDFN)) Q:APCDTDFN=""  D PHDSP
  1.  ; <CLEANUP>
  1. PMHX K APCDTDFN,APCDTN,APCDTICD,APCDTICL,APCDTNRQ,APCDTDAT,APCDTDTH,APCDTICF,APCDTQ,APCDTCVD,Y
  1.  Q
  1. PHDSP S APCDTN=^AUPNPH(APCDTDFN,0)
  1.  S APCDTICD=$P(APCDTN,U) D GETICDDX
  1.  S Y=$P(APCDTN,U,3) X APCDTCVD S APCDTDAT=Y
  1.  S APCDTDTH=$P(APCDTN,U,5) I APCDTDTH]"" S Y=APCDTDTH X APCDTCVD S APCDTDTH=Y
  1.  S APCDTNRQ=$P(APCDTN,U,4)
  1.  D GETNARR
  1.  I APCDTDTH]"" S:APCDTNRQ]"" APCDTNRQ=APCDTNRQ_" " S APCDTNRQ=APCDTNRQ_"(onset "_APCDTDTH_")"
  1.  W APCDTDAT,?12,$$VAL^XBDIQ1(9000013,APCDTDFN,.01) S APCDTICL=22 D PRTICD
  1.  Q
  1.  ;
  1. GETICDDX ;
  1.  S:APCDTICF="S" APCDTICD=$P($$ICDDX^ICDEX(APCDTICD,$P(APCDTN,U,3)),U,4)
  1.  Q
  1. GETICDOP ;
  1.  S:APCDTICF="S" APCDTICD=$P($$ICDOP^ICDEX(APCDTICD,$P(APCDTN,U,3),,"I"),U,5)
  1.  Q
  1.  ;
  1. PRTICD ;
  1.  S:APCDTNRQ="" APCDTNRQ="<no narrative provided>" S APCDTICD=""
  1.  S APCDTTXT=APCDTICD D PRTTXT
  1.  Q
  1.  ;
  1. PRTTXT ; GENERALIZED TEXT PRINTER
  1.  S APCDTDLT=1,APCDTILN=80-APCDTICL-1
  1.  F APCDTQ=0:0 S:APCDTNRQ]""&(($L(APCDTNRQ)+$L(APCDTTXT)+2)<255) APCDTTXT=$S(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ,APCDTNRQ="" Q:APCDTTXT=""  D PRTTXT2
  1.  K APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT
  1.  Q
  1. PRTTXT2 D GETFRAG W ?APCDTICL W APCDTF,! S APCDTICL=APCDTICL+APCDTDLT,APCDTILN=APCDTILN-APCDTDLT,APCDTDLT=0
  1.  Q
  1. GETFRAG I $L(APCDTTXT)<APCDTILN S APCDTF=APCDTTXT,APCDTTXT="" Q
  1.  F APCDTC=APCDTILN:-1:1 Q:$E(APCDTTXT,APCDTC)=" "
  1.  S APCDTF=$E(APCDTTXT,1,APCDTC-1),APCDTTXT=$E(APCDTTXT,APCDTC+1,255)
  1.  Q
  1.  ;
  1. GETNARR ;
  1.  ;I APCDTNRQ]"" S APCDTNRQ=$S($D(^AUTNPOV(APCDTNRQ)):$P(^AUTNPOV(APCDTNRQ,0),U),1:"***** "_APCDTNRQ_" *****")
  1.  ;E  S APCDTNRQ=""
  1.  Q
  1.  ;
  1. GETSITEV ;
  1.  S %=^AUPNVSIT(APCDTVDF,0),APCDTVSC=$P(%,U,7),APCDTITE=$P(%,U,6)
  1. GETSITE ;
  1.  S:APCDTITE="" APCDTITE="null"
  1.  S %=$G(^AUTTLOC(APCDTITE,0))
  1.  S APCDTNFL=$P(%,U),APCDTNFL=$S($D(^DIC(4,APCDTITE,0)):$P(^(0),U),1:"<"_APCDTITE_">")
  1.  S APCDTNSH=$P(%,U,2) I APCDTNSH="" S APCDTNSH="<"_APCDTITE_">"
  1.  S APCDTNAB=$J($P(%,U,7),4) I APCDTNAB="" S APCDTNAB="<"_APCDTITE_">"
  1.  Q
  1. REF ;EP - called from [APCD REF] template to 
  1.  ;display currently documented refusals
  1.  Q:'$D(^AUPNPREF("AC",APCDPAT))
  1.  K APCDREF
  1.  NEW APCDX,A,B,C,D S APCDX=0 F  S APCDX=$O(^AUPNPREF("AC",APCDPAT,APCDX)) Q:APCDX'=+APCDX  D
  1.  .S A=$P(^AUPNPREF(APCDX,0),U),B=$P(^AUPNPREF(APCDX,0),U,4),D=$P(^AUPNPREF(APCDX,0),U,3)
  1.  .Q:B=""
  1.  .Q:A=""
  1.  .Q:D=""
  1.  .S D=9999999-D,APCDREF(A,B,9999999-D)=APCDX
  1.  .Q
  1.  W !!,"Last of each service type documented in PCC for "_$P(^DPT(APCDPAT,0),U)_":",!
  1.  S A="" F  S A=$O(APCDREF(A)) Q:A'=+A  S B="" F  S B=$O(APCDREF(A,B)) Q:B=""  D
  1.  .S D=$O(APCDREF(A,B,0))
  1.  .S APCDX=APCDREF(A,B,D)
  1.  .W !?2,$E($$VAL^XBDIQ1(9000022,APCDX,.01),1,15),?19,$$VAL^XBDIQ1(9000022,APCDX,.04),?62,$$VAL^XBDIQ1(9000022,APCDX,.03)
  1.  .W !?5,"Service Type:  ",$$VAL^XBDIQ1(9000022,APCDX,.07)
  1.  .Q
  1.  W !
  1.  Q
  1. IMMCPT ;EP - called from APCD CPT templates
  1.  NEW X
  1.  ; S X=$P(^ICPT(APCDCPTP,0),U)
  1.  S X=$P($$CPT^ICPTCOD(APCDCPTP),U,2)
  1.  I +X<90471 Q
  1.  I +X>90749 Q
  1.  W !!,"REMINDER:  You have entered a CPT code for an immunization.  Please check the",!,"immunizations listed below and make sure the immunization has been entered using",!,"the IM mnemonic as well as with the CPT mnemonic."
  1.  I '$O(^AUPNVIMM("AD",APCDVSIT,0)) W !,"There are no immunizations entered via the IM mnemonic.",! Q
  1.  NEW Y S X=0 F  S X=$O(^AUPNVIMM("AD",APCDVSIT,X)) Q:X'=+X  D
  1.  .W !?5,$P(^AUTTIMM($P(^AUPNVIMM(X,0),U),0),U),?40,"code: ",$P(^AUTTIMM($P(^AUPNVIMM(X,0),U),0),U,3)
  1.  .Q
  1.  W !
  1.  Q