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

APCDVDSG.m

Go to the documentation of this file. 
  1. APCDVDSG ; IHS/CMI/LAB -VISIT DISPLAY ;
  1.  ;;2.0;IHS PCC SUITE;**2,4,5,10,11,13,17**;MAY 14, 2009;Build 18
  1.  ;
  1. EN(APCDVIEN,APCDARRY,APCDGUI) ;EP
  1.  I $G(APCDARRY)="" S APCDARRY="^TMP(""APCDVDSG"",$J)"
  1.  Q:'$D(APCDVIEN)
  1.  Q:'APCDVIEN
  1.  Q:'$D(^AUPNVSIT(APCDVIEN,0))
  1.  D BUILD
  1.  D XIT
  1.  Q
  1.  ;
  1. SET ;set array
  1.  S APCDCTR=APCDCTR+1
  1.  S @APCDARRY@(APCDCTR,0)=APCDSTR
  1.  S APCDSTR=""
  1.  Q
  1. BUILD ; build array
  1.  NEW APCDAR,APCDF,APCDVREC,APCDV,APCDH,APCDSTR,APCDVFLE,APCDVNM,APCDVI,APCDNARR,APCDVDG,APCDVIGR,APCDJ,APCDF1,APCDVFC
  1.  NEW F,F1,X,H
  1.  K APCDAR
  1.  D TERM^VALM0
  1.  S APCDVREC=^AUPNVSIT(APCDVIEN,0)
  1.  S Y=$P(APCDVREC,U,5) D ^AUPNPAT
  1.  S APCDSTR="",APCDCTR=0
  1.  I $G(APCDGUI) S (IOINHI,IOINORM)=""
  1.  S APCDH="Patient Name",APCDV=IOINHI_$E($P(^DPT($P(APCDVREC,U,5),0),U),1,20)_IOINORM D BUILD1
  1.  S APCDH="Chart #",APCDV=IOINHI_$S($D(^AUPNPAT($P(APCDVREC,U,5),41,DUZ(2),0)):$P(^(0),U,2),1:"None")_IOINORM D BUILD1
  1.  S APCDH="Date of Birth" S Y=AUPNDOB D DD^%DT S APCDV=Y D BUILD1
  1.  S APCDH="Sex",APCDV=AUPNSEX D BUILD1
  1.  S APCDH="Visit IEN",APCDV=APCDVIEN D BUILD1
  1.  S APCDSTR="" D SET
  1. VISIT ;
  1.  S APCDSTR="=============== "_IOINHI_"VISIT FILE"_IOINORM_" ===============",X=(80-$L(APCDSTR)\2) D SET ;$J("",X)_APCDSTR D SET
  1.  S F=0 F  S F=$O(^DD(9000010,F)) Q:F'=+F!(F>999999)  D
  1.  .K APCDAR,APCDNARR
  1.  .I +$P(^DD(9000010,F,0),U,2) D  Q  ;MULTIPLE AND WP FIELDS
  1.  ..S APCDF=+$P(^DD(9000010,F,0),U,2)
  1.  ..I $P($G(^DD(APCDF,.01,0)),U,2)'["W" D  Q  ;multiple
  1.  ...D GETS^DIQ(9000010,APCDVIEN_",",F_"*","","APCDAR")
  1.  ...I '$D(APCDAR) Q
  1.  ...;S APCDSTR="" D SET
  1.  ...S APCDJ="" F  S APCDJ=$O(APCDAR(APCDF,APCDJ)) Q:APCDJ=""  D
  1.  ....S APCDF1=0 F  S APCDF1=$O(APCDAR(APCDF,APCDJ,APCDF1)) Q:APCDF1=""  D
  1.  .....S APCDH=$P(^DD(APCDF,APCDF1,0),U,1)  ;field name
  1.  .....I $O(APCDAR(APCDF,APCDJ,APCDF1,0)) D  Q
  1.  ......S APCDSTR=APCDH_":" D SET
  1.  ......S X=0 F  S X=$O(APCDAR(APCDF,APCDJ,APCDF1,X)) Q:X'=+X  S APCDSTR=APCDAR(APCDF,APCDJ,APCDF1,X) D SET
  1.  .....S APCDV=APCDAR(APCDF,APCDJ,APCDF1)
  1.  .....D BUILD1
  1.  ..D GETS^DIQ(9000010,APCDVIEN_",",F,"","APCDAR")
  1.  ..I $O(APCDAR(9000010,APCDVIEN_",",F,0)) D  Q  ;wp
  1.  ...S APCDSTR=$P(^DD(9000010,F,0),U,1)_":" D SET
  1.  ...S APCDNARR=""
  1.  ...S F1=0 F  S F1=$O(APCDAR(9000010,APCDVIEN_",",F,F1)) Q:F1'=+F1  D
  1.  ....S APCDV=APCDAR(9000010,APCDVIEN_",",F,F1)
  1.  ....D BUILD1
  1.  .K APCDNARR
  1.  .I '+$P(^DD(9000010,F,0),U,2) D  ;SINGLE VALUED FIELD
  1.  ..S APCDF=9000010
  1.  ..D GETS^DIQ(APCDF,APCDVIEN_",",F,"E","APCDAR")
  1.  ..I $G(APCDAR(APCDF,APCDVIEN_",",F,"E"))]"" D
  1.  ...S APCDH=$P(^DD(9000010,F,0),U)
  1.  ...S APCDV=APCDAR(APCDF,APCDVIEN_",",F,"E")
  1.  ...D BUILD1
  1.  ...Q
  1.  I $O(^AUPNCANT(APCDVIEN,11,0)) D
  1.  .S APCDSTR="" D SET
  1.  .S APCDH=$P(^DD(9000095,1100,0),U)
  1.  .S APCDV="" D BUILD1
  1.  .S F=0 F  S F=$O(^AUPNCANT(APCDVIEN,11,F)) Q:F'=+F  D
  1.  ..S APCDSTR=$G(^AUPNCANT(APCDVIEN,11,F,0)) D SET
  1.  S APCDSTR="" D SET
  1.  Q:'$P(APCDVREC,U,9)
  1. VFILES ;set up array of all v file entries
  1.  NEW DA,D0,DIC,DIQ,DR,DI
  1.  S APCDVFLE=9000010 F  S APCDVFLE=$O(^DIC(APCDVFLE)) Q:APCDVFLE>9000010.99!(APCDVFLE'=+APCDVFLE)  D VF2
  1.  D XIT
  1.  Q
  1.  ;
  1. VF2 ;
  1.  S APCDVNM=$P(^DIC(APCDVFLE,0),U),APCDVDG=^DIC(APCDVFLE,0,"GL"),APCDVIGR=APCDVDG_"""AD"",APCDVIEN,APCDVDFN)",APCDVDFN=""
  1.  S APCDVFC=0 F APCDVI=1:1 S APCDVDFN=$O(@APCDVIGR) Q:APCDVDFN=""  D VF3
  1.  Q
  1.  ;
  1. VF3 ;
  1.  I APCDVFLE=9000010.01 Q:$P($G(^AUPNVMSR(APCDVDFN,2)),U,1)  ;measurements entered in error
  1.  I APCDVFLE=9000010.54 Q:$P($G(^AUPNVRUP(APCDVDFN,2)),U,1)  ;V updated/reviewed entered in error
  1.  I APCDVFLE=9000010.62 Q:$P($G(^AUPNVAMI(APCDVDFN,5)),U,1)  ;V AMI entered in error
  1.  I APCDVFLE=9000010.63 Q:$P($G(^AUPNVSTR(APCDVDFN,5)),U,1)  ;V STROKE entered in error
  1.  I APCDVFLE=9000010.51 Q:$P($G(^AUPNVACG(APCDVDFN,1)),U,1)  ;V ANTICOAG entered in error
  1.  I APCDVFLE=9000010.58 Q:$P($G(^AUPNVVI(APCDVDFN,0)),U,6)  ;V VISIT INSTRUCTIONS entered in error
  1.  I APCDVFLE=9000010.43 Q:$P($G(^AUPNVOB(APCDVDFN,0)),U,6)  ;V OB entered in error
  1.  S APCDVFC=APCDVFC+1
  1.  I APCDVFC<2 S APCDSTR="" D SET S APCDSTR="=============== "_IOINHI_$P(APCDVNM,"V ",2)_"s"_IOINORM_" ===============",X=(80-$L(APCDSTR)\2) D SET ;$J("",X)_APCDSTR D SET
  1.  ;S APCDH="IEN",APCDV=APCDVDFN D BUILD1  ;IHS/CMI/GRL
  1.  ;K APCDAR,APCDNARR D ENP^XBDIQ1(APCDVFLE,APCDVDFN,".01:.019999;.04:999999","APCDAR(","E")
  1.  I APCDVFC>1 S APCDSTR="" D SET
  1.  S F=0 F  S F=$O(^DD(APCDVFLE,F)) Q:F'=+F!(F>999999)  D
  1.  .K APCDAR,APCDNARR
  1.  .Q:F=".02"
  1.  .Q:F=".03"
  1.  .I +$P(^DD(APCDVFLE,F,0),U,2) D  Q  ;MULTIPLE AND WP FIELDS
  1.  ..S APCDF=+$P(^DD(APCDVFLE,F,0),U,2)
  1.  ..I $P($G(^DD(APCDF,.01,0)),U,2)'["W" D  Q  ;multiple
  1.  ...D GETS^DIQ(APCDVFLE,APCDVDFN_",",F_"*","","APCDAR")
  1.  ...I '$D(APCDAR) Q
  1.  ...;S APCDSTR="" D SET
  1.  ...S APCDJ="" F  S APCDJ=$O(APCDAR(APCDF,APCDJ)) Q:APCDJ=""  D
  1.  ....S APCDF1=0 F  S APCDF1=$O(APCDAR(APCDF,APCDJ,APCDF1)) Q:APCDF1=""  D
  1.  .....S APCDH=$P(^DD(APCDF,APCDF1,0),U,1)  ;field name
  1.  .....I $O(APCDAR(APCDF,APCDJ,APCDF1,0)) D  Q
  1.  ......S APCDSTR=APCDH_":" D SET
  1.  ......S X=0 F  S X=$O(APCDAR(APCDF,APCDJ,APCDF1,X)) Q:X'=+X  S APCDSTR=APCDAR(APCDF,APCDJ,APCDF1,X) D SET
  1.  .....S APCDV=APCDAR(APCDF,APCDJ,APCDF1)
  1.  .....D BUILD1
  1.  ..D GETS^DIQ(APCDVFLE,APCDVDFN_",",F,"","APCDAR")
  1.  ..I $O(APCDAR(APCDVFLE,APCDVDFN_",",F,0)) D  Q  ;wp
  1.  ...S APCDSTR=$P(^DD(APCDVFLE,F,0),U,1)_":" D SET
  1.  ...S APCDNARR=""
  1.  ...S F1=0 F  S F1=$O(APCDAR(APCDVFLE,APCDVDFN_",",F,F1)) Q:F1'=+F1  D
  1.  ....S APCDV=APCDAR(APCDVFLE,APCDVDFN_",",F,F1)
  1.  ....D BUILD1
  1.  .K APCDNARR
  1.  .I '+$P(^DD(APCDVFLE,F,0),U,2) D  ;SINGLE VALUED FIELD
  1.  ..S APCDF=APCDVFLE
  1.  ..D GETS^DIQ(APCDF,APCDVDFN_",",F,"E","APCDAR")
  1.  ..I $G(APCDAR(APCDF,APCDVDFN_",",F,"E"))]"" D
  1.  ...S APCDH=$P(^DD(APCDVFLE,F,0),U)
  1.  ...S APCDV=APCDAR(APCDF,APCDVDFN_",",F,"E")
  1.  ...D BUILD1
  1.  ...I APCDVFLE=9000010.07,F=.01 D MAPADV(APCDVIEN,APCDVDFN)
  1.  ...Q
  1.  ;I APCDVFLE=9000010.09,$O(^AUPNVLAB(APCDVDFN,21,0)) D
  1.  ;.S APCDSTR="COMMENTS:" D SET
  1.  ;.S F=0 F  S F=$O(^AUPNVLAB(APCDVDFN,21,F)) Q:F'=+F  D
  1.  ;..S APCDSTR="  "_$P(^AUPNVLAB(APCDVDFN,21,F,0),U) D SET
  1.  I APCDVFLE=9000010.28 S X=$P(^AUPNVNOT(APCDVDFN,0),U) D
  1.  .I $$VAL^XBDIQ1(8925,X,.05)="RETRACTED" D
  1.  ..S APCDH="RETRACTED DATE",APCDV=$$VAL^XBDIQ1(8925,X,1611) D BUILD1
  1.  ..S APCDH="RETRACTED BY",APCDV=$$VAL^XBDIQ1(8925,X,1610) D BUILD1
  1.  I APCDVFLE=9000010.01 D
  1.  .;if entered in error, display reason
  1.  I $G(DUZ(0))="@" S APCDH="V FILE IEN",APCDV=APCDVDFN D BUILD1  ;IHS/CMI/GRL
  1.  Q
  1. BUILD1 ;
  1.  I $D(APCDNARR) S APCDSTR="",APCDSTR=$$SETSTR^VALM1(APCDV,APCDSTR,1,$L(APCDV)) D SET Q
  1.  S APCDSTR=$E(APCDH,1,21)_":",APCDSTR=$$SETSTR^VALM1(APCDV,APCDSTR,24,$L(APCDV))
  1.  D SET
  1.  Q
  1.  I $L(APCDSTR)>39 D SET
  1.  S APCDV=" "_APCDV_" ",X=APCDH_": "_APCDV
  1.  I $L(APCDSTR),$L(X)>40 D SET
  1.  I $L(APCDSTR) S APCDSTR=$$SETSTR^VALM1(X,APCDSTR,40,$L(X))
  1.  I '$L(APCDSTR) S APCDSTR=X
  1.  K APCDV,APCDH,X
  1.  Q
  1. XIT ;
  1.  K APCDAR,APCDARRY,APCDCTR,APCDH,APCDSTR,APCDV,APCDVDFN,APCDVDG,APCDVFLE,APCDVI,APCDVIEN,APCDVIGR,APCDFL,APCDVNM,APCDVREC,APCDH,APCDNARR
  1.  K DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z,F1
  1.  Q
  1. MAPADV(V,I) ;
  1.  NEW F,D,C,APCDSMA
  1.  S D=$$VD^APCLV(V)
  1.  S D=$$IMP^AUPNSICD(D)
  1.  I D'=30 Q  ;ICD10 ONLY
  1.  S C=$$VAL^XBDIQ1(9000010.07,I,1101)
  1.  ;GET MAP ADVICE
  1.  S D=$$I10ADV^BSTSAPI("APCDSMA",C)
  1.  I 'D Q  ;NO MAP ADVICE
  1.  S APCDSTR="MAP ADVICE IS AVAILABLE"
  1.  D SET
  1.  Q