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

ACHSDFL.m

Go to the documentation of this file. 
  1. ACHSDFL ; IHS/ITSC/PMF - DEFERRED SERVICES LETTER (1/2) ;JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,23**;JUN 11,2001;Build 43
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES & CHANGED ZTSK TO ZTQUEQUED
  1.  ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
  1.  ;
  1.  ;IHS/SET/JVK ACHS*3.1*6 3/24/2003 SET THE LETTER WITH TO 75
  1.  ;S DIWL=5,DIWR=$S($G(IOM):IOM,1:75),DIWF="W"
  1.  S DIWL=5,DIWR=75,DIWF="W"
  1. PAT ; --- Select Deferred Service
  1.  W !!
  1.  K DIC,A,ACHSA
  1.  S DIC("S")="I $E($P($G(^(0)),U))'=""#"",$P($G(^(0)),U,14)'=""Y"""
  1.  S DIC("W")="W "" ""_$S($P($G(^(0)),U,5)=""Y"":$P($G(^DPT($P($G(^(0)),U,6),0)),U),$P($G(^(0)),U,5)=""N"":$P($G(^(0)),U,7),1:""UNDEFINED"")"
  1.  S DIC="^ACHSDEF("_DUZ(2)_",""D"","
  1.  S DIC(0)="AEMQZ"
  1.  ;{ABK,3/31/10}S DIC("A")="Enter DEFERRED SERVICES NUMBER or PATIENT'S NAME: "
  1.  S DIC("A")="Enter UNMET NEEDS NUMBER or PATIENT'S NAME: "
  1.  S DA(1)=DUZ(2)
  1.  D ^DIC
  1.  K DIC
  1.  I +Y="" D END1 Q
  1.  I +Y<1 D END1 Q
  1.  ;
  1.  S ACHSA=+Y
  1.  G P0:'$P(Y(0),U,6)
  1.  G P0:'$D(^DPT($P(Y(0),U,6),0))
  1.  S DFN=$P(Y(0),U,6)
  1.  G P1
  1.  ;
  1. P0 ;
  1.  S X=$P(Y(0),U,7)
  1.  I '$L(X) D NAMERR G PAT
  1. P1 ;
  1.  ;{ABK,3/31/10}W !!,"You wish to print deferred services letter ",$P(Y(0),U),!!
  1.  W !!,"You wish to print unmet needs letter ",$P(Y(0),U),!!
  1.  G P2:'$D(DFN)
  1.  W ?5,$P($G(^DPT(DFN,0)),U)
  1.  S X=$G(^DPT(DFN,.11))
  1.  W !?5,$P(X,U),!?5,$P(X,U,4)
  1.  S Y=$P(X,U,5)
  1.  I Y]"",$D(^DIC(5,Y,0)) W ", ",$P($G(^DIC(5,Y,0)),U,2)
  1.  W " ",$P(X,U,6),!!
  1.  G P3
  1. P2 ;
  1.  S X=$G(^ACHSDEF(DUZ(2),"D",ACHSA,0))
  1.  W ?5,$P(X,U,7),!?5,$P(X,U,8),!?5,$P(X,U,9)
  1.  S Y=$P(X,U,10)
  1.  I Y]"",$D(^DIC(5,Y,0)) W ", ",$P($G(^DIC(5,Y,0)),U,2)
  1.  W " ",$P(X,U,11),!!
  1. P3 ;
  1.  S %=$$DIR^ACHS("Y","Is this correct","YES","","",2)
  1.  I $D(DTOUT)!$D(DUOUT) D END Q
  1.  G PAT:'%
  1. DEV ;
  1.  W !!
  1.  S %ZIS="OPQ"
  1.  D ^%ZIS
  1.  I POP D HOME^%ZIS D END Q
  1.  G:'$D(IO("Q")) START^ACHSDFL1
  1.  K IO("Q")
  1.  I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
  1.  ;{ABK, 3/31/10}S ZTRTN="START^ACHSDFL1",ZTDESC="CHS Deferred Services Letter",ZTSAVE("ACHSA")=""
  1.  S ZTRTN="START^ACHSDFL1",ZTDESC="CHS Unmet Needs Letter",ZTSAVE("ACHSA")=""
  1.  D ^%ZTLOAD
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ
  1.  ;G:'$D(ZTSK) DEV
  1.  G:'$D(ZTQUEQUED) DEV
  1.  Q
  1.  ;
  1. NAMERR ;
  1.  W !!,*7,"No valid PATIENT NAME in this file.",!,"No letter may be printed until a valid patient is entered.",!!
  1.  Q
  1.  ;
  1. END ;EP
  1.  W !!!
  1.  I $D(ACHDONE) F I=1:1:4 W "*** OFFICE COPY *** "
  1.  I $$DF^ACHS(0,14)="Y" F I=1:1:4 W "DOCUMENT CANCELLED *"
  1.  ;IHS/SET/JVK ACHS*3.1*6 3/24/2003 SET THE LETTER WIDTH TO 75 AND FIX PG NUMBERING VAR ACHSPG
  1.  ;I $D(ACHDONE) K ACHDONE D RTRN^ACHS W @IOF S ACHDPG=1,DIWL=5,DIWR=$S($G(IOM):IOM,1:75),DIWF="W" G DOC^ACHSDFL1
  1.  I $D(ACHDONE) K ACHDONE D RTRN^ACHS W @IOF S ACHSPG=1,DIWL=5,DIWR=75,DIWF="W" G DOC^ACHSDFL1
  1.  I IO(0)=IO D RTRN^ACHS
  1.  K ACHSA,ACHDST,ACHDPAT,ACHDX,ACHSDDX
  1. END1 ;
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. TYPE ;EP
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES TO FOR LOOP
  1.  I $D(^ACHSDEF(DUZ(2),"D",ACHSA,200)) S ACHDX=0 F  S ACHDX=$O(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX)) Q:+ACHDX=0  D
  1.  . S ACHSDDX=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U)
  1.  . I $P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U,2)]"" W !,?DIWL+10,$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U,2),!
  1.  . E  W !,?DIWL+10 I ACHSDDX,$P($$ICDDX^ICDEX(ACHSDDX),U,6) W $P(^ICM($P($$ICDDX^ICDEX(ACHSDDX),U,6),0),U)  ;ACHS*3.1*23 ICD-10
  1.  . ;E  W !,?DIWL+10 I ACHSDDX,$P($$ICDDX^ICDCODE(ACHSDDX),U,6) W $P(^ICM($P($$ICDDX^ICDCODE(ACHSDDX),U,6),0),U)  ;ACHS*3.1*23 ICD-10
  1.  . ;E  W !,?DIWL+10,$P($G(^ICD9($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,ACHDX,0)),U),0)),U,3),!
  1.  ;
  1.  I $D(^ACHSDEF(DUZ(2),"D",ACHSA,300)) S ACHDX=0 F  S ACHDX=$O(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX)) Q:+ACHDX=0  D
  1.  . I $P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U,2)]"" W !,?DIWL+10,$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U,2)
  1.  . ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
  1.  . ;E  W !,?DIWL+10,$P($G(^ICPT($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U),0)),U),!
  1.  . E  W !,?DIWL+10,$P($$CPT^ICPTCOD($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,ACHDX,0)),U)),U,2),!
  1.  ;
  1.  W !
  1.  Q
  1.  ;