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