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

DGREG0.m

Go to the documentation of this file. 
  1. DGREG0 ;ALB/JDS,AEG,JAM - REGISTER A PATIENT, CONT. ;03 OCT 85
  1.  ;;5.3;Registration;**108,121,91,149,326,624,1111**;Aug 13, 1993;Build 18
  1. REFILE F I=0,1,2,3 S A(I)="" S:$D(^DPT(DFN,"DIS",DFN1,I)) A(I)=^(I)
  1.  S DIV=$S('$D(^DG(40.8,+$P(A(0),"^",4),0)):1,1:$P(A(0),"^",4))
  1.  ;I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3
  1.  S X=+$P(A(0),"^",4),X=$S($D(^DG(40.8,X,"DEV")):^("DEV"),1:"1^1^1") F I=1:1:3 S:'$D(DGIO($P("10^PRF^RT","^",I))) DGIO($P("10^PRF^RT","^",I))=$S($P(X,U,I)]"":$P(X,U,I),1:1)
  1.  S DGIO("HS")=DGIO("PRF") ;HS DEVICE=PROFILE DEVICE
  1.  F I=10,"PRF","RT" I $D(DGIO(I)) S DGHIO(I)=DGIO(I)
  1.  F I=1010,1010.176,1010.18,1010.17 S B(I)="" S:$D(^DPT(DFN,I)) B(I)=^(I)
  1.  S INTL="",INTL=$$GET1^DIQ(200,+$P(A(0),"^",5),1,"I") S:INTL="" INTL=0
  1.  S I=1010,B(I)=$P(A(0),"^",3)_"^"_$P(B(I)_"^^^^^^^^^","^",2,8)_"^"_(+A(0))_"^"_INTL_"^"_$P(B(I),"^",11,99)
  1.  S:A(1)'="" B(1010.18)=A(1) S I1=$P(A(2),"^",6),I1=$P($S($D(^DIC(36,+I1,0)):^(0),1:""),"^",1),I=1010.176,B(I)=$P(A(2)_"^^^^","^",2,3)_"^"_$P(A(2),"^",7)_"^"_$E(I1,1,45)_"^"_$P(B(I),5,99)
  1.  S X=3,X1=1,X2=2
  1. MOVE S S(X1)=$P(A(X),"^",X2),S(X1+1)=$P(A(X),"^",X2+1),S(X1+2)=$P(A(X),"^",X2+2),S(X1+3)=$P(A(X),"^",X2+3)_$S($D(^DIC(5,+$P(A(X),"^",X2+4),0)):", "_$P(^(0),"^",2),1:"")_$S($P(A(X),"^",X2+5)'="":"  ",1:"")_$P(A(X),"^",X2+5)
  1.  S:S(X1+2)="" S(X1+2)=S(X1+3),S(X1+3)="" S:S(X1+1)="" S(X1+1)=S(X1+2),S(X1+2)=S(X1+3),S(X1+3)="" S:S(X1)="" S(X1)=S(X1+1),S(X1+1)=S(X1+2),S(X1+2)=S(X1+3),S(X1+3)=""
  1.  S I1=S(1) F I=2:1:4 S:S(I)'="" I1=I1_"/"_S(I)
  1.  S:$P(A(3),"^",8)'="" I1=I1_" "_$P(A(3),"^",8) S I1=$E(I1,1,45),I=1010.17,B(I)=$P(B(I)_"^^^","^",1,3)_"^"_$P(A(3),"^",1)_"^"_I1_"^"_$P(B(I),"^",6,99)
  1.  F I=1010,1010.176,1010.17,1010.18 S:B(I)'=""&(B(I)'?1"^"."^") ^DPT(DFN,I)=B(I)
  1.  K B,S,I,I1,L,L1,L2,LL,LL1,LL2,DR,DEF
  1.  D MT
  1.  D CP
  1.  D EN1^DGEN(DFN) ;enrollment
  1. W1 F I=10,"PRF","RT","HS" I $D(DGHIO(I)) S DGIO(I)=DGHIO(I)
  1.  K DGHIO
  1.  G ^DGREG00
  1. Q K:'$D(DGASKDEV) DGIO
  1. Q1 ;If Send HL7 V2.3 messaging flag is set to SEND or SUSPEND and
  1.  ;If user exits Register a Patient option or 10-10t Registration
  1.  ;having edited some fields but not completing the Registration
  1.  ;then send an A08 message
  1.  I $P($$SEND^VAFHUTL(),"^",2) D HL7A08^VAFCDD01
  1.  ;
  1. QE K %,%DT,A,B,ANS,APD,B,CURR,DA,DB,DE,DEF,DGCLPR,DGDAY,DGDFN,DGE,DGERR,DGL,DGLL,DFMD,DGNEW,DGO,DIC,DIE,DINUM,DOW,DP,DR,I,I1,IOZBK,IOZFO,L,L1,L2,LL,LL1,LL2,MDCARD,PARA,PRF,RT,S,SC,SEEN
  1.  K VAFHMRG,VAFHBEF,VAFHFLG,VET,X,X1,X2,Y,Y1,ZTSK,D0,D1,DIV,DLAYGO,J,PGM,Z
  1.  G A^DGREG:('$D(DGRPFEE)&('$D(RGMPI))) Q
  1.  ;
  1. DT G DT^DIQ:Y
  1.  Q
  1. SSD Q:'$D(^DPT(DA(1),.321))  S DGZ1=0 F I=1:1:3 I $P(^DPT(DA(1),.321),"^",I)["Y" S DGZ1=1 Q
  1.  I 'DGZ1 K DGZ1 Q
  1.  S:'$D(^DPT("ASDPSD","B",SDIV,(9999999-DA)\1,DA(1))) ^(DA(1))=0 S:'$D(^DPT("ASDPSD","C",SDIV,SDX,9999999-DA,DA(1))) ^(DA(1))="E"
  1.  K DGZ1 Q
  1. SSDK I $D(^DPT("ASDPSD","C",SDIV,SDX,(9999999-DA),DA(1))) K ^(DA(1))
  1.  Q
  1.  ;
  1. CP ;If not (autoexempt or MTested) & no CP test this year then
  1.  ;prompt for add/edit cp test
  1.  N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
  1.  G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
  1.  S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
  1.  D EN^DGMTCOR
  1.  I +$G(DGNOCOPF) S DGMTCOR=0
  1.  I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
  1.  K DGNOCOPF
  1. QTCP Q
  1. MT ;Check if user requires a means test.  Ask user if s/he wants to
  1.  ;proceed if one is required.
  1.  N DGREQF,DIV
  1.  D EN^DGMTR
  1.  I DGREQF D MTDT:APD\1<DT,EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
  1.  Q
  1.  ;
  1. MTDT ;Date of Test should be the same as the Registration Date
  1.  N DA,DGMT,DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTINF,DGMTP,DGMTYPT,DIE,DR
  1.  S DGMT=$$LST^DGMTU(DFN) G MTDTQ:$P(DGMT,"^",2)'=DT
  1.  S DGMTI=+DGMT,DGMTDT=APD\1,DGMTYPT=1
  1.  S DGMTACT="STA" D PRIOR^DGMTEVT
  1.  S DIE="^DGMT(408.31,",DA=DGMTI,DR=".01///^S X="_DGMTDT D ^DIE
  1.  D AFTER^DGMTEVT S DGMTINF=1 D EN^DGMTEVT
  1. MTDTQ Q
  1.  ;
  1. COMMENTS ;DG*5.3*1111 comments moved here due to size limit of DGREG
  1.  ;DG*5.3*1111 - Commented out the following code
  1.  ;I DGCHK=1 D
  1.  ;. S DA=DFN1,DIE("NO^")=""
  1.  ;. S DA(1)=DFN,DP=2.101
  1.  ;. S DR="1///"_$S(SEEN=2:2,SEEN=1:0,1:0)_";Q;2//OUTPATIENT MEDICAL"_";7///"_$S(SEEN=2:0,SEEN=1:1,1:0)_";2.1//ALL OTHER;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4///"_DUZ
  1.  ;I DGCHK=0 D
  1.  ;. S DA=DFN1,DIE("NO^")=""
  1.  ;. S DA(1)=DFN,DP=2.101
  1.  ;. S DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
  1.  ;DG*5.3*1111-Removed the TYPE OF BENEFIT APPLIED FOR (#2) field and the TYPE OF CARE APPLIED FOR (#2.1) field of the DISPOSITION LOG-IN DATE/TIME file (#2.101) prompts from the DG REGISTER PATIENT process.
  1.  ; Removed updating the STATUS (#2.101,1) and EXAMINED IN MEDICAL CENTER (#2.101,7) fields due to the removal of the "Is the patient currently being followed in a clinic for the same condition" and
  1.  ; "Is the patient to be examined in the medical center today" prompts. These prompt set the SEEN and CURR variables that were used to set these fields.
  1.  Q