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

ACHSDAR.m

Go to the documentation of this file. 
  1. ACHSDAR ; IHS/ITSC/PMF - PATIENT ALTERNATE RESOURCE LETTER (1/2) ;   [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1. PAT ;
  1.  S ACHDOCT="alternate resource"
  1.  D ^ACHSDLK                     ;STANDARD PATIENT LOOKUP
  1.  I $D(ACHDLKER) D END1^ACHSDAR1 Q
  1. P4 ;
  1.  ;ARE THERE 'OTHER RESOURCES'
  1.  I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,0)),U,4) G P5
  1.  ;
  1.  ;ARE THERE 'OTHER IHS RESOURCES'
  1.  I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,825,0)),U,4) G P5
  1.  W !!!,*7,*7,?10,"No Alternate Resources For This Patient. ",!
  1.  G ENTER:$$DIR^ACHS("Y","          Do You Wish To Enter One Now","NO","Enter 'YES' to enter an Alternate Resource for this patient","",1)
  1.  S ACHDLKER=""
  1.  D END^ACHSDAR4
  1.  Q
  1.  ;
  1. P5 ;
  1.  ;I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,0)),U,4)=1 S ACHDALRS=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,0)),U,3) G OPTION
  1.  W !!?10,"ALTERNATE RESOURCES AVAILABLE FOR THIS PATIENT.",!!
  1.  ;
  1.  ;LIST 'OTHER RESOURCES'
  1.  S (ACHD,ACHDX)=0
  1.  F  S ACHD=$O(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHD)) Q:'ACHD  D
  1.  .S ACHDX=ACHDX+1
  1.  .W ?13,ACHDX,". ",$P($G(^AUTNINS($P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHD,0),"UNDEFINED"),U),4),"UNDEFINED"),U),!
  1.  ;
  1.  ;S %=$$DIR^ACHS("N^1:"_ACHDX,"          Alternate Resource","Select an Alternate Resource by entering a number.","","",2)
  1.  S DIR(0)="N^1:"_ACHDX
  1.  S DIR("A")="Select an Alternate Resource: "
  1.  S DIR("?")="Enter a number."
  1.  D ^DIR
  1.  I $D(DUOUT)!$D(DTOUT)!('%) G PAT
  1.  S ACHDALRS=+%
  1.  ;IS THIS THE ALTERNATE RESOURCE WE SEND THE LETTER TO? 
  1.  ;
  1.  ;IT IS UNCLEAR WHETHER THIS IS SOMETHING THE SITES DO OR NOT
  1.  ;THE ONLY ALTERNATE RESOURCE IS TO REFER THEM TO ANOTHER SITE WITHIN
  1.  ;COVERAGE AREA. WE WILL KEEP THIS SECTION IF THIS TURNS OUT TO BE
  1.  ;PERTINENT LATER
  1. OPTION ;  
  1.  ;I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,0)) W !!!,"No Alternate Resources Options on File",! G OPTION1
  1.  ;I $D(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,0)) W !!!,"Alternate Resources Options On File",!
  1.  ;
  1.  ;GET OTHER RESOURCES OPTIONS
  1.  ;S ACHDI=0
  1.  ;F  S ACHDI=$O(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,ACHDI)) Q:'ACHDI  D
  1.  ;.S OTHRSC=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,ACHDI,0)),U)
  1.  ;.Q:OTHRSC=""
  1.  ;.W !,ACHDI,". ",$P($G(^ACHSDENR(DUZ(2),12,OTHRSC,0)),U)
  1.  ;
  1.  ;S %=$$DIR^ACHS("Y","Do You Wish To Enter More","NO","","",1)
  1.  ;G DEV:'%
  1.  ;G END^ACHDAR1:$D(DUOUT)!$D(DTOUT)
  1.  ;
  1.  ;ALLOW ENTRY OF ALTERNATE RESOURCE OPTIONS
  1.  ;W !!!?10,"ALTERNATE RESOURCES OPTIONS",!
  1. OPTION1 ;
  1.  ;S (ACHD,ACHDX)=0
  1.  ;F  S ACHDX=$O(^ACHSDENR(DUZ(2),12,ACHDX)) Q:'ACHDX  D
  1.  ;.S ACHD=ACHD+1
  1.  ;.W !?10,ACHD_". ",$P($G(^ACHSDENR(DUZ(2),12,ACHDX,0),"UNDEFINED"),U)
  1.  ;
  1.  ;I ACHD=0 W !,"No alternate resource options found for this facility!" G DEV
  1.  ;S %=$$DIR^ACHS("NO^1:"_ACHD,"          Enter Number Of Option <RETURN> To Continue","","Enter a number to select an option","",1)
  1.  ;G DEV:'%
  1.  ;I $D(DUOUT)!$D(DTOUT) G END^ACHDAR1
  1.  ;
  1.  ;S ACHDQ=+%,X=0
  1.  ;F  S X=$O(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,X)) Q:+X=0  I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,X,0),"UNDEFINED"),U)=ACHDQ W !!,*7,"Option Already Selected",*7,!! G OPTION
  1.  ;
  1.  ;I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,0)) S ^ACHSDEN(DUZ(2),"D",ACHDA,800,ACHDALRS,3,0)=$$ZEROTH^ACHS(9002071,1,800,7)
  1.  ;
  1.  ;S X=%
  1.  ;S DIC="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",800,"_ACHDALRS_",3,"
  1.  ;S DA(3)=DUZ(2)
  1.  ;S DA(2)=ACHSA
  1.  ;S DA(1)=ACHDALRS
  1.  ;S DIC(0)="QEMZ"
  1.  ;K DD,DO
  1.  ;D FILE^DICN
  1.  ;
  1.  ;GET 'OTHER RESOURCES OPTION'
  1.  ;S ACHDOP=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,ACHDALRS,3,0)),U,3)
  1.  ;I ACHDQ=2 W !!,"Do You Want To Enter Documentation Now",!! S %=$$DIR^ACHS("Y","Enter Documentation Now","NO","","",1) D:% ENTDOC^ACHDAR5
  1.  ;I ACHDQ=ACHD S DIC="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",800,"_ACHDALRS_",3,"_ACHDOP_",1"
  1.  ;S DA(4)=DUZ(2)
  1.  ;S DA(3)=ACHSA
  1.  ;S DA(2)=ACHDALRS
  1.  ;S DA(1)=ACHDOP D EN^DIWE
  1.  ;G OPTION
  1.  ;
  1. DEV ;
  1.  W !!
  1.  S %ZIS="OPQ"
  1.  D ^%ZIS
  1.  I POP D HOME^%ZIS G END^ACHSDAR1
  1.  G:'$D(IO("Q")) START^ACHSDAR1
  1.  K IO("Q")
  1.  I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
  1.  S ZTRTN="START^ACHSDAR1",ZTDESC="CHS ALTERNATE RESOURCE LETTER"
  1.  F %="ACHSA","ACHDALRS" S ZTSAVE(%)=""
  1.  D ^%ZTLOAD
  1.  G:'$D(ZTSK) DEV
  1.  Q
  1.  ;
  1. ENTER ;
  1.  W !!
  1.  I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,800,0)) S ^ACHSDEN(DUZ(2),"D",ACHSA,800,0)=$$ZEROTH^ACHS(9002071,1,800)
  1.  S DA(2)=DUZ(2)
  1.  S DA(1)=ACHSA
  1.  S DIC="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",800,"
  1.  S DIC(0)="AQELM"
  1.  D ^DIC
  1.  G:Y<1 P4
  1.  W !!
  1.  S DA(2)=DUZ(2)
  1.  S DA(1)=ACHSA
  1.  S DIE=DIC
  1.  S DR="2;5"
  1.  D ^DIE
  1.  G P4
  1.  ;