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

AGED8.m

Go to the documentation of this file. 
  1. AGED8 ; IHS/ASDS/EFG - EDIT DEATH INFO/OTHER NAMES ;  
  1.  ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
  1.  ;
  1.  S AG("N")=5
  1. VAR D DRAW
  1.  Q:$D(AGSEENLY)
  1.  W !?10,"Enter ""4"" to edit OTHER NAMES or ""5"" to edit LEGAL NAMES."
  1.  W !,AGLINE("EQ")
  1.  I '$D(AGSEENLY) D
  1.  . K DIR
  1.  . S DIR("?")="Enter your choice now."
  1.  . S DIR("?",1)="You may enter the item number of the field you wish to edit,"
  1.  . S DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"
  1.  . S DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"
  1.  . S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."
  1.  . S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "
  1.  D READ^AGED1
  1.  Q:$D(DTOUT)!$D(DFOUT)
  1.  Q:$D(DUOUT)&$D(AGXTERN)
  1.  G ^AGED13:$D(DUOUT)&'$D(AGXTERN),VAR:$D(AG("ERR")),END:$D(DLOUT)!(Y["N") G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED"))
  1.  I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR
  1.  W !!
  1. CC S AG("C")="DATE^AGED8,STATE^AGED8,CERT^AGED8,ALIAS^AG3A,NAMCHG^AGNAMCHG"
  1. C ;EP - Edit multiple fields on a Reg edit page.
  1.  S AGY=Y F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N"))  D @($P(AG("C"),",",AG("SEL")))
  1.  D UPDATE1^AGED(DUZ(2),DFN,8,"") K AGI,AGY
  1.  G VAR
  1. END K AG,DFOUT,DQOUT,DTOUT,DLOUT,DA,DIC,DIE,DR,AGSCRN,Y
  1.  K ROUTID
  1.  Q:$D(AGXTERN)
  1.  Q:$D(DIROUT)
  1.  Q:$D(AGSEENLY)
  1.  G ^AGED13:$D(DUOUT)
  1.  G ^AGED11
  1.  Q
  1. DATE ;EP (string in AGED8).
  1.  K A S DIE="^DPT(",DR=.351,DA=DFN D ^DIE
  1.  I $D(^DPT(DFN,.35)) S $P(^AUPNPAT(DFN,11),U,29)=DT
  1.  ;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
  1.  I $$AGE^AGUTILS(DFN)<3,($$DECEASED^AGEDERR2(AGPATDFN)) D AUTOADD^BIPATE(DFN,DUZ(2),.AGERR,$P($G(^DPT(DFN,.35)),U))
  1.  ;END NEW CODE
  1.  Q
  1. STATE ;EP (string in AGED8).
  1.  S DIE="^AUPNPAT(",DR=1115,DA=DFN D ^DIE Q
  1. CERT ;EP (string in AGED8).
  1.  S DIE="^AUPNPAT(",DR=1116,DA=DFN D ^DIE Q
  1. LEGNAM ;
  1.  N DIC,DIR,DA,X,Y
  1.  K DTOUT,DUOUT
  1.  I $D(^AUPNNAMC("C",DFN))  D
  1.  . S (PTR,REC,PRFPTR)=0
  1.  . S (DTCHG,CHGTO,PROOF)=""
  1.  . W !,"CHANGED TO"
  1.  . W ?32,"BY"
  1.  . W ?38,"PROOF"
  1.  . W ?54,"DOC. #"
  1.  . W ?70,"DATE"
  1.  . W !,"5. "
  1.  . F  S PTR=$O(^AUPNNAMC("C",DFN,PTR)) Q:'PTR  D
  1.  .. S REC=$G(^AUPNNAMC(PTR,0))
  1.  .. S DTCHG=$P($P(REC,U),".")
  1.  .. S CHGTO=$P(REC,U,3)
  1.  .. S PRFPTR=$P(REC,U,4)
  1.  .. S DOCNUM=$P(REC,U,5)
  1.  .. S USER=$P(REC,U,6)
  1.  .. I PRFPTR>0 S PROOF=$E($P($G(^AUPNELM(PRFPTR,0)),U),1,20)
  1.  .. W ?4,$E(CHGTO,1,30)
  1.  .. I USER>0 W ?32,$P($G(^VA(200,USER,0)),U,2)
  1.  .. I PRFPTR>0 W ?38,$E(PROOF,1,15)
  1.  .. W ?54,$E(DOCNUM,1,15)
  1.  .. W ?70,$E(DTCHG,4,5)_"/"_$E(DTCHG,6,7)_"/"_($E(DTCHG,1,3)+1700),!
  1.  Q
  1. DRAW ;EP
  1.  S AG("PG")=7
  1.  S ROUTID=$P($T(+1)," ")
  1.  D ^AGED
  1.  K ^UTILITY("DIQ1",$J)
  1.  F AG=1:1 D  Q:$G(AGSCRN)[("*END*")
  1.  . S AGSCRN=$P($T(@1+AG),";;",2,4)
  1.  . Q:AGSCRN[("*END*")
  1.  . S CAPTION=$P(AGSCRN,U)
  1.  . S DIC=$P(AGSCRN,U,3)
  1.  . S DR=$P(AGSCRN,U,4)
  1.  . S NEWLINE=$P(AGSCRN,U,5)
  1.  . S CAPDENT=$P(AGSCRN,U,2)
  1.  . W @NEWLINE,AG,".",@CAPDENT,$S($G(CAPTION)'="":CAPTION,1:$P($G(^DD(DIC,DR,0)),U))_" : "
  1.  . W $$GET1^DIQ(DIC,DFN,DR)
  1.  . I AG=1 D
  1.  .. I $P($G(^DPT(DFN,.35)),U,2)'="" D
  1.  ... W ?45,"Edited by "_$P($G(^VA(200,$P($G(^DPT(DFN,.35)),U,2),0)),U,2)
  1.  .. I $P($G(^AUPNPAT(DFN,11)),U,29)'="" S Y=$P($G(^AUPNPAT(DFN,11)),U,29) D DD^%DT D
  1.  ... W " on "_Y
  1.  W !,$E(AGLINE("-"),1,33) W ?33," Other Names ",$E(AGLINE("-"),1,34)
  1.  W !,"4. "
  1.  I $D(^DPT(DFN,.01,0)) D
  1.  .S DIC=2
  1.  .S DR(2.01)=.01
  1.  .S DR=1
  1.  .S DA=DFN
  1.  .S DAIEN=0
  1.  .F  S DAIEN=$O(^DPT(DFN,.01,DAIEN)) Q:+DAIEN=0  D
  1.  .. S DA(2.01)=DAIEN
  1.  .. K AGRES
  1.  .. S DIQ="AGRES",DIQ(0)="E" D EN^DIQ1
  1.  .. W:$G(AGRES(2.01,DAIEN,.01,"E"))'="" ?4,$G(AGRES(2.01,DAIEN,.01,"E")),!
  1.  .. K AGRES,TEMPDIC,AGRES
  1.  W !,$E(AGLINE("-"),1,33) W ?33," Legal Names ",$E(AGLINE("-"),1,34)
  1.  D LEGNAM
  1.  Q
  1.  ; ****************************************************************
  1.  ; ON LINES BELOW:
  1.  ; U "^" DELIMITED
  1.  ; PIECE 1= FLD LBL
  1.  ; PIECE 2= POSITION ON LINE TO DISP ITEM #
  1.  ; PIECE 3= FILE #
  1.  ; PIECE 4= FLD #
  1.  ; PIECE 5= NEW LINE OR NOT (MUST BE EITHER A '!' OR '?#') USE THIS TO INDENT THE CAP
  1.  ; PIECE 6= ITEM # OVERIDE. USE THIS TO ASSIGN THE ITEM # USED TO CHOOSE THIS
  1.  ;          FLD ON THE SCREEN
  1.  ; PIECE 7= TAG TO CALL WHEN THIS FLD IS CHOSEN TO EDIT
  1.  ; 
  1.  ; BAR "|" DELIMITED
  1.  ; PIECE 2= EXECUTE CODE TO GET FLD THAT ANOTHER IS POINTING TO. EXECUTED AFT FLD PRINT
  1.  ; PIECE 3= EXECUTE CODE TO DO BEF FLD DATA PRINTS. USE TO SCREEN OUT PRINTING A FLDS DATA
  1.  ; PIECE 4= EXECUTE CODE TO DO BEF PRINTING THE CAP OR FLD LBL. USE TO SCREEN OUT PRINTING A CAP/FLD LBL
  1.  ; PIECE 5= EXECUTE CODE TO DO AFT PRINTING THE FLD DATA
  1. 1 ;
  1.  ;;^?11^2^.351^!^1
  1.  ;;^?10^9000001^1115^!^2
  1.  ;;^?3^9000001^1116^!^3
  1.  ;;*END*