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

APCHS8.m

Go to the documentation of this file. 
  1. APCHS8 ; IHS/CMI/LAB - PART 8 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS PCC SUITE;**2,7,10**;MAY 14, 2009;Build 88
  1.  ;
  1. OFFHX ; ********** OFFSPRING HISTORY * 9000012 **********
  1.  ; <SETUP>
  1.  Q:$P(^DPT(APCHSPAT,0),U,2)'="F"
  1.  Q:'$D(^AUPNOFFH("AA",APCHSPAT))
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  X APCHSCKP Q:$D(APCHSQIT)  D OFFHDR
  1.  ; <DISPLAY>
  1.  S APCHSDAT=0 F APCHSQ=0:0 S APCHSDAT=$O(^AUPNOFFH("AA",APCHSPAT,APCHSDAT)) Q:'APCHSDAT  S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNOFFH("AA",APCHSPAT,APCHSDAT,APCHSDFN)) Q:'APCHSDFN  D OFFDSP Q:$D(APCHSQIT)
  1. OFFHXX K APCHSDAT,APCHSDFN,APCHSN,APCHSP,X,Y
  1.  Q
  1. OFFDSP ;
  1.  S APCHSN=^AUPNOFFH(APCHSDFN,0)
  1.  X APCHSCKP Q:$D(APCHSQIT)  D:APCHSNPG OFFHDR
  1.  S Y=APCHSDAT X APCHSCVD W Y,?10,$P(APCHSN,U,4),?20,$P(APCHSN,U,5),?24,$J(+$P(APCHSN,U,6),5,2),?31,$P(APCHSN,U,7)
  1.  I $P(APCHSN,U,8) W ?35,$P(APCHSN,U,8),"/",$S($P(APCHSN,U,9):$P(APCHSN,U,9),1:"-")
  1.  I $P(APCHSN,U,11) S Y=$P(APCHSN,U,11) X APCHSCVD S Y="("_Y_$S($P(APCHSN,U,12)]"":": "_$P(APCHSN,U,12),1:"")_")" W ?42,$E(Y,1,36)
  1.  W !
  1. PNC I $O(^AUPNOFFH(APCHSDFN,21,0)) W ?10,"PERINATAL COMPLICATION: " S APCHSP=0 F  S APCHSP=$O(^AUPNOFFH(APCHSDFN,21,APCHSP)) Q:'APCHSP  S Y=^(APCHSP,0) D OUTC Q:$D(APCHSQIT)
  1.  Q:$D(APCHSQIT)
  1. NNC I $O(^AUPNOFFH(APCHSDFN,31,0)) W ?10,"NEONATAL COMPLICATION: " S APCHSP=0 F  S APCHSP=$O(^AUPNOFFH(APCHSDFN,31,APCHSP)) Q:'APCHSP  S Y=^(APCHSP,0) D OUTC Q:$D(APCHSQIT)
  1.  Q
  1. OFFHDR W "DOB",?10,"NAME",?20,"SEX",?25,"BWT",?31,"EGA",?35,"APGAR",?42,"DEATH",!
  1.  Q
  1. OUTC X APCHSCKP Q:$D(APCHSQIT)  D:APCHSNPG OFFHDR
  1.  W ?34,Y,!
  1.  Q
  1.  ;
  1. REPHX ; ********** REPRODUCTIVE HISTORY * 9000017 **********
  1.  ; <SETUP>
  1.  G REPHX^APCHS85
  1.  ;
  1. TRTMT ; ********** TREATMENTS * 9000010.15 **********
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVTRT("AA",APCHSPAT))
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ; <DISPLAY>
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVTRT("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDTT=Y S APCHSDTU=0 D ONEDATE Q:$D(APCHSQIT)  S APCHSNDM=APCHSNDM-APCHSDTU Q:APCHSNDM=0
  1.  ; <CLEANUP>
  1. TRTMTX K APCHSVDF,APCHSIVD,APCHSDTU,APCHSDTT,APCHSDFN,APCHSFO,APCHSFAC,APCHSNT,APCHST,APCHSLVL,APCHSLVT,APCHSN
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
  1.  Q
  1. ONEDATE S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVTRT("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:APCHSDFN=""  D TRTCHK Q:$D(APCHSQIT)
  1.  Q
  1. TRTCHK S APCHSN=^AUPNVTRT(APCHSDFN,0)
  1.  Q:'$P(^AUTTTRT($P(APCHSN,U,1),0),U,3)
  1.  S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL Q:"ADTC"'[APCHSVSC
  1.  X APCHSCKP Q:$D(APCHSQIT)  S:APCHSNPG APCHSDTU=0
  1.  I 'APCHSDTU W APCHSDTT S APCHSFO=""
  1.  I APCHSNSH=APCHSFO S APCHSFAC=""
  1.  E  S (APCHSFAC,APCHSFO)=APCHSNSH
  1.  S APCHSDTU=1
  1.  S APCHST=$P(APCHSN,U,1),APCHST=$P(^AUTTTRT(APCHST,0),U,1)
  1.  S APCHSNT=+$P(APCHSN,U,4)
  1.  S APCHSLVL=$P(APCHSN,U,6),APCHSLVT=""
  1.  I APCHSLVL]"" S APCHSLVT=$P(^DD(9000010.15,.06,0),U,3),APCHSLVT=$P($P(APCHSLVT,APCHSLVL_":",2),";",1),APCHSLVT=" - "_$P(APCHSLVT,",",1)_" UNDERSTANDING"
  1.  X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG APCHSDTT W ?10,$E(APCHSFAC,1,10),?21,APCHST," (",APCHSNT,")",APCHSLVT,!
  1.  Q
  1.  ;
  1. TXC ;EP - called from component 
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVTXC("AA",APCHSPAT))
  1.  X APCHSBRK
  1.  ; <DISPLAY>
  1.  S APCHST="" F APCHSQ=0:0 S APCHST=$O(^AUPNVTXC("AA",APCHSPAT,APCHST)) Q:APCHST=""  S APCHSTX=$$EXTSET^XBFUNC(9000010.39,.01,APCHST),APCHSTL=$L(APCHSTX) X APCHSCKP Q:$D(APCHSQIT)  D TXDSP6
  1.  ; <CLEANUP>
  1. TXCX K APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSDI,APCHSVDF,APCHSDAT,APCHSCNT,APCHS,X,Y
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
  1.  Q
  1. TXDSP6 ;get contract type
  1.  S APCHSCNT=0
  1.  W ! X APCHSCKP Q:$D(APCHSQIT)  W APCHSTX S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVTXC("AA",APCHSPAT,APCHST,APCHSIVD)) S APCHSCNT=APCHSCNT+1 Q:APCHSIVD=""!(APCHSCNT>6)  D TXDSP13
  1.  Q
  1. TXDSP13 ;
  1.  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVTXC("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN)) Q:'APCHSDFN!(APCHSCNT>6)  D TXDSP23
  1.  Q
  1. TXDSP23 ;
  1.  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S APCHSVDF=$P(^AUPNVTXC(APCHSDFN,0),U,3) ;D GETSITEV^APCHSUTL S APCHSITE=APCHSNSH
  1.  S APCHSDI=$$VAL^XBDIQ1(9000010.39,APCHSDFN,.04)
  1.  S APCHSPI=$$VAL^XBDIQ1(9000010.39,APCHSDFN,.05)
  1.  X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG APCHSTX W ?20,APCHSDI,?40,APCHSPI,!
  1.  Q
  1. BIRTHM ; ********** BIRTH MEASUREMENTS 9000024 AND V INFANT FEEDING 9000010.44 **********
  1.  ; <SETUP>
  1.  I '$D(^AUPNBMSR("B",APCHSPAT)),'$O(^AUPNVIF("AC",APCHSPAT,0)) Q
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ; <DISPLAY>
  1.  S APCHX=$G(^AUPNBMSR(APCHSPAT,0))
  1.  S %=$P(APCHX,U,18),%=%+.0005
  1.  W "BIRTH WEIGHT (kg)",?30,$$STRIP^XLFSTR($J($P(APCHX,U,18),10,3))
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S %=$P(APCHX,U,22) ;,%=%+.0005
  1.  W "BIRTH LENGTH (inches)",?30,$$STRIP^XLFSTR($J($P(APCHX,U,22),6,2))
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W !,"BIRTH ORDER" S X=$P(APCHX,U,11) S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" W ?30,X
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S X=$P(APCHX,U,12) W !,"FORMULA STARTED (age)" S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" W ?30,X
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S X=$P(APCHX,U,14) W !,"BREAST STOPPED (age)" S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" W ?30,X
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S X=$P(APCHX,U,16) W !,"SOLIDS BEGUN (age)" S:X["W" X=+X_" weeks" S:X["D" X=+X_" days" S:X["M" X=+X_" months" S:X["Y" X=+X_" years" W ?30,X
  1.  Q:'$O(^AUPNVIF("AC",APCHSPAT,0))
  1.  K APCHT S APCHX=0 F  S APCHX=$O(^AUPNVIF("AC",APCHSPAT,APCHX)) Q:APCHX'=+APCHX  D
  1.  .S V=$P(^AUPNVIF(APCHX,0),U,3)
  1.  .Q:'V
  1.  .S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:V=""
  1.  .S APCHT(V,APCHX)=$$AGE^AUPNPAT(APCHSPAT,V,"E")_U_$$VAL^XBDIQ1(9000010.44,APCHX,.01)
  1.  .Q
  1.  ;write out data
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W !!,"VISIT DATE",?20,"AGE",?32,"FEEDING CHOICE",!
  1.  S APCHD=0 F  S APCHD=$O(APCHT(APCHD)) Q:APCHD'=+APCHD!($D(APCHSQIT))  S APCHX=0 F  S APCHX=$O(APCHT(APCHD,APCHX)) Q:APCHX'=+APCHX!($D(APCHSQIT))  D
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W $$DATE^APCHSMU(APCHD),?20,$P(APCHT(APCHD,APCHX),U),?32,$P(APCHT(APCHD,APCHX),U,2),!
  1.  .;ADDITIONAL FEEDING CHOICES
  1.  .Q:'$O(^AUPNVIF(APCHX,13,0))
  1.  .W ?10,"ADDITIONAL FEEDING CHOICES:"
  1.  .S APCHAX=0 F  S APCHAX=$O(^AUPNVIF(APCHX,13,APCHAX)) Q:APCHAX'=+APCHAX  D
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..S APCHIENS=APCHAX_","_APCHX
  1.  ..S X=$P($G(^AUPNVIF(APCHX,13,APCHAX,0)),U,1) W ?40,$$GET1^DIQ(9000010.4413,APCHIENS,.01),!
  1.  ..I $P($G(^AUPNVIF(APCHX,13,APCHAX,0)),U,2)]"" W ?10,"COMMENT: ",$$GET1^DIQ(9000010.4413,APCHIENS,.02),!
  1.  .Q
  1. BRTHX K APCHSDAT,APCHSDFN,APCHSN,APCHSP,X,Y,APCHX,APCHT,APCHD,APCHAX,APCHIENS
  1.  Q
  1. NRS ; ******************* NRS  - LAST 3  * 9000010.49 *******
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVNTS("AA",APCHSPAT))
  1.  X APCHSBRK
  1.  ; <DISPLAY>
  1.  D NRDSP3
  1.  ; <CLEANUP>
  1.  K APCHST,APCHSFN
  1. NRS3X K APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,APCHSCNT,APCHS,X,Y
  1.  K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
  1.  Q
  1. NRDSP3 ;get NRS type
  1.  X APCHSCKP
  1.  Q:$D(APCHSQIT)
  1.  W ?1,"DATE",?12,"PROVIDER",?32,"RISK",?72,"RD ",!?72,"REFERRAL",!!
  1.  S APCHSCNT=0,APCHSEX=0
  1.  F  S APCHSEX=$O(^AUPNVNTS("AA",APCHSPAT,APCHSEX)) Q:APCHSEX'=+APCHSEX!($D(APCHSQIT))!(APCHSCNT>3)  D
  1.  .S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVNTS("AA",APCHSPAT,APCHSEX,APCHSIVD)) S APCHSCNT=APCHSCNT+1 Q:APCHSIVD=""!(APCHSCNT>3)!($D(APCHSQIT))  D NRDSP13
  1.  Q
  1. NRDSP13 ;get NRS test DFN
  1.  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVNTS("AA",APCHSPAT,APCHSEX,APCHSIVD,APCHSDFN)) Q:'APCHSDFN!(APCHSCNT>3)!($D(APCHSQIT))  D NRDSP23
  1.  Q
  1. NRDSP23 ;compile data & display NRS test
  1.  S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  Q:'$D(^AUPNVNTS(APCHSDFN,0))
  1.  S APCHSPR=$E($$VAL^XBDIQ1(9000010.49,APCHSDFN,1204),1,18)
  1.  S APCHSREF=$S($P(^AUPNVNTS(APCHSDFN,0),U,15):"Yes",1:"No")
  1.  S APCHRISK=$$VAL^XBDIQ1(9000010.49,APCHSDFN,.14) I APCHRISK]"" S APCHRISK=APCHRISK_": "
  1.  S C=0 I $P(^AUPNVNTS(APCHSDFN,0),U,4) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Age 70+"
  1.  ;I $P(^AUPNVNTS(APCHSDFN,0),U,4) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Age 70+"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,5) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Nut Supp"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,6) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Weight"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,7) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Diagnosis"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,8) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Appetite"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,9) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Diff Chew"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,10) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Food Aller/Intol"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,11) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Vom/Diarr"
  1.  I $P(^AUPNVNTS(APCHSDFN,0),U,12) S C=C+1 S:C>1 APCHRISK=APCHRISK_"; " S APCHRISK=APCHRISK_"Other: "_$P(^AUPNVNTS(APCHSDFN,0),U,13)
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  W ?1,APCHSDAT,?12,APCHSPR
  1.  K ^UTILITY($J,"W") S X=APCHRISK,DIWL=0,DIWR=40 D ^DIWP
  1.  W ?32,^UTILITY($J,"W",0,1,0)
  1.  W ?74,APCHSREF,!
  1.  F APCHSX=2:1:$G(^UTILITY($J,"W",0)) D  Q:$D(APCHSQIT)
  1.  .X APCHSCKP Q:$D(APCHSQIT)
  1.  .W ?32,^UTILITY($J,"W",0,APCHSX,0),!
  1.  K ^UTILITY($J)
  1.  Q
  1.  ;
  1. IMAGING ;
  1.  Q:'$D(^RADPT(APCHSPAT))
  1.  X APCHSBRK
  1.  K APCHSARR
  1.  D SVR(APCHSPAT,$S(APCHSNDM=-1:9999999,1:APCHSNDM),$S(APCHSDLM=9999999:0,1:(9999999-APCHSDLM)),.APCHSARR)
  1.  D PRINT(.APCHSARR)
  1.  K APCHSARR
  1.  Q
  1. SVR(DFN,MAX,START,LINE)    ; RADIOLOGY REPORTS
  1.  I $G(DFN),$G(MAX),$G(START)]""
  1.  E  Q
  1.  N X,Y,Z,T,%,IDT,IDT2,EDT,GBL,PCC,RIEN,ARR,EXDT
  1.  N CASE,ESTAT,PRIEN,RCIEN,RDFN,RDOC,RSTAT,CNT,CPT,CPTIEN,MOD,PCE,PMIEN,PROC,TAB,TOT
  1.  S IDT=0,T="~",CNT=0
  1.  S IDT2=9999999-START
  1.  S GBL=$NA(^RADPT(DFN,"DT"))
  1. RPASS1 ;
  1.  F  Q:CNT>MAX  S IDT=$O(@GBL@(IDT)) Q:'IDT  Q:IDT>IDT2  D
  1.  . S EDT=+$G(@GBL@(IDT,0)) I 'EDT Q
  1.  . S EXDT=$$FMTE^XLFDT(EDT,2),EXDT=$TR(EXDT,"@"," "),EXDT=$P(EXDT,":",1,2)
  1.  . S RCIEN=0
  1.  . F  S RCIEN=$O(@GBL@(IDT,"P",RCIEN)) Q:'RCIEN  D
  1.  .. S X=$G(@GBL@(IDT,"P",RCIEN,0)) I X="" Q
  1.  .. S RIEN=$P(X,U,17) I RIEN="" Q
  1.  .. S RSTAT="",%=$P($G(^RARPT(RIEN,0)),U,5)
  1.  .. I $L(%) S RSTAT=$S(%="V":"VERIFIED",%="R":"RELEASED/NOT VERIFIED",%="PD":"PROBLEM DRAFT",%="D":"DRAFT",1:"")
  1.  .. S CNT=CNT+1 ; DONT WORRY ABOUT THE COUNT UNTIL THE NEXT DATE
  1.  .. S CASE=$P(X,U) I CASE="" Q
  1.  .. S ESTAT="",%=$P(X,U,3) ; NEEDS TRANSLATION
  1.  .. I % S ESTAT=$P($G(^RA(72,%,0)),U)
  1.  .. S RDFN=$P(X,U,15),RDOC=""
  1.  .. I RDFN S RDOC=$P($G(^VA(200,RDFN,0)),U)
  1.  .. S PRIEN=$P(X,U,2) I 'PRIEN Q
  1.  .. S Y=$G(^RAMIS(71,PRIEN,0)) I Y="" Q
  1.  .. S PROC=$P(Y,U) I PROC="" Q
  1.  .. S CPTIEN=+$P(Y,U,9)
  1.  .. S CPT=$P($G(^ICPT(CPTIEN,0)),U)
  1.  .. S MIEN=0,MOD=""
  1.  .. F  S MIEN=$O(@GBL@(IDT,"P",RCIEN,"M",MIEN)) Q:'MIEN  D
  1.  ... S PMIEN=+$G(@GBL@(IDT,"P",RCIEN,"M",MIEN,0)) I 'PMIEN Q
  1.  ... S %=$P($G(^RAMIS(71.2,PMIEN,0)),U) I %="" Q
  1.  ... I MOD'="" S MOD=MOD_", "
  1.  ... S MOD=MOD_%
  1.  ... Q
  1.  .. S ARR(CNT)=EXDT_T_PROC_T_MOD_T_CPT_T_RDOC_T_CASE_T_ESTAT_T_RSTAT
  1.  .. S Z=0
  1.  .. F  S Z=$O(@GBL@(IDT,"P",RCIEN,"H",Z)) Q:'Z  S ARR(CNT,"H",Z)=$G(@GBL@(IDT,"P",RCIEN,"H",Z,0)) ; HX
  1.  .. S Z=0
  1.  .. F  S Z=$O(^RARPT(RIEN,"R",Z)) Q:'Z  S ARR(CNT,"R",Z)=$G(^RARPT(RIEN,"R",Z,0)) ; REPORT
  1.  .. S Z=0
  1.  .. F  S Z=$O(^RARPT(RIEN,"I",Z)) Q:'Z  S ARR(CNT,"I",Z)=$G(^RARPT(RIEN,"I",Z,0)) ; IMPRESSION
  1.  .. Q
  1.  . Q
  1. RPASS2 ;
  1.  S ARR="HEADER"_T_"Procedure: "_T_"Procedure Modifier: "_T_"CPT Code: "_T_"Interpreting Staff: "_T_"Exam Case Number: "_T_"Exam Status: "_T_"Report Status: "
  1.  S CNT=0,LINE(1)="-----  IMAGING PROFILE  -----",LINE=1,TAB="  "
  1.  F  S CNT=$O(ARR(CNT)) Q:'CNT  D
  1.  . S TOT=$L(ARR(CNT),T) I 'TOT Q
  1.  . F PCE=1:1:TOT D
  1.  .. I PCE=1 S X=$P(ARR(CNT),T,1)_"  "_$P(ARR(CNT),T,2),PCE=2
  1.  .. E  S X=TAB_$P(ARR,T,PCE)_$P(ARR(CNT),T,PCE)
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=X
  1.  .. Q
  1.  . S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
  1.  . S LINE(LINE)=TAB_"History: "
  1.  . S Z=0
  1.  . F  S Z=$O(ARR(CNT,"H",Z)) Q:'Z  D
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=TAB_"  "_ARR(CNT,"H",Z)
  1.  .. Q
  1.  . S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
  1.  . S LINE(LINE)=TAB_"Report: "
  1.  . S Z=0
  1.  . F  S Z=$O(ARR(CNT,"R",Z)) Q:'Z  D
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=TAB_"  "_ARR(CNT,"R",Z)
  1.  .. Q
  1.  . S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
  1.  . S LINE(LINE)=TAB_"Impression: "
  1.  . S Z=0
  1.  . F  S Z=$O(ARR(CNT,"I",Z)) Q:'Z  D
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=TAB_"  "_ARR(CNT,"I",Z)
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ; 
  1. PRINT(LINE) ; EP-PRINT RESULTS
  1.  N CNT
  1.  S CNT=0
  1.  F  S CNT=$O(LINE(CNT)) Q:'CNT  D  I $D(APCHSQIT) Q
  1.  . W !
  1.  . X APCHSCKP Q:$D(APCHSQIT)
  1.  . S X=LINE(CNT)
  1.  . W X
  1.  . Q
  1.  Q
  1.  ;