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

APCDHOS.m

Go to the documentation of this file. 
  1. APCDHOS ; IHS/CMI/LAB - DISPLAY HISTORY OF SURGERY ;
  1.  ;;2.0;IHS PCC SUITE;**1,11,12**;MAY 14, 2009;Build 3
  1. HOS ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
  1.  ; <SETUP>
  1.  D DATE
  1.  S APCDTICF="S"
  1.  I '$D(^AUPNVPRC("AC",APCDPAT)) W !!,"***************** NO SURGICAL HISTORY ON FILE ******************",!! Q
  1.  W !!,"************************ SURGICAL HISTORY **********************",!!
  1.  S APCDTCNT=0
  1.  K ^TMP($J,"APCDMPRCTAX") ;IHS/CMI/LAB - ICD SPEED UP
  1.  S F=$NA(^TMP($J,"APCDMPRCTAX"))  ;IHS/CMI/LAB - ICD SPEED UP
  1.  D BLDTAX^ATXAPI("APCH MINOR SURGICAL PROCS",F,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)))  ;IHS/CMI/LAB - ICD SPEED UP
  1.  ; <DISPLAY>
  1.  S APCDTIVD=0 F APCDTQ=0:0 S APCDTIVD=$O(^AUPNVPRC("AA",APCDPAT,APCDTIVD)) Q:'APCDTIVD  S APCDTDFN=0 F APCDTQ=0:0 S APCDTDFN=$O(^AUPNVPRC("AA",APCDPAT,APCDTIVD,APCDTDFN)) Q:'APCDTDFN  D HOSDSP
  1.  I 'APCDTCNT W "Minor procedures are on file but have not been displayed.",!
  1.  ; <CLEANUP>
  1. HOSX K APCDTDFN,APCDTICD,APCDTNRQ,APCDTDAT,APCDTDS,APCDTICL,APCDTIVD,APCDTCOD,APCDTCNT,APCDTN,APCDTICF,APCDTCVD,APCDTNTD,APCDTQ,Y
  1.  K ^TMP($J,"APCDMPRCTAX")
  1.  Q
  1. HOSDSP S APCDTN=^AUPNVPRC(APCDTDFN,0)
  1.  S APCDTICD=$P(APCDTN,U)
  1.  D HOSCHK Q:APCDTICD=""
  1.  S APCDTCNT=APCDTCNT+1
  1.  D GETICDOP
  1.  S Y=$P(APCDTN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCDTCVD S APCDTDAT=Y
  1.  S APCDTNRQ=$P(APCDTN,U,4)
  1.  D GETNARR
  1.  S APCDTDS="DATE?" D
  1.  .S Y=$P(APCDTN,U,6) I Y]"" X APCDTCVD S APCDTDS=Y Q
  1.  .S Y=(9999999-APCDTIVD) X APCDTCVD S APCDTDS=Y
  1.  W APCDTDS,?12,$$VAL^XBDIQ1(9000010.08,APCDTDFN,.01) S APCDTNTD=APCDTDAT S APCDTICL=22 D PRTICD
  1.  Q
  1. HOSCHK ;
  1.  ;S APCDTCOD=$P($$ICDDX^ICDEX(APCDTICD),U,2)
  1.  ;I $$ICD^ATXAPI(APCDTICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S APCDTICD=""
  1.  S:$D(^TMP($J,"APCDMPRCTAX",APCDTICD)) APCDTICD="" Q
  1.  Q
  1.  ;
  1. GETICDDX ;
  1.  S:APCDTICF="S" APCDTICD=$P($$ICDDX^ICDEX(APCDTICD,$$VD^APCLV($P(APCDTN,U,3))),U,4)
  1.  Q
  1. GETICDOP ;
  1.  S:APCDTICF="S" APCDTICD=$P($$ICDOP^ICDEX(APCDTICD,$$VD^APCLV($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. 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