DGPMV36 ;ALB/MIR - TREATING SPECIALTY TRANSFER, CONTINUED ; [ 03/15/2002 10:14 AM ]
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 2/21/2001 Used IHS input templates
; 3/09/2001 Added IHS ^utility nodes for event driver
; 7/06/2001 Removed stuffing of DX into comments
; 7/25/2001 Added check for silent API
; 7/26/2001 Added check for DGQUIET to write statements
;
;I '$P(DGPMA,"^",9) S DGPMA="",DIK="^DGPM(",DA=DGPMDA D ^DIK K DIK W !,"Incomplete Treating Specialty Transfer...Deleted" ;IHS/ANMC/LJF 7/26/2001
I '$P(DGPMA,"^",9) S DGPMA="",DIK="^DGPM(",DA=DGPMDA D ^DIK K DIK W:'$D(DGQUIET) !,"Incomplete Treating Specialty Transfer...Deleted" ;IHS/ANMC/LJF 7/26/2001
Q
;
DICS ; -- check that it is a PROVIDER/SPECIALTY change
S DGER=DGPMTYP'=20
Q
;
ONLY ; -- determine if there is only one 'specialty xfr' type mvt
N C,I S C=0
F I=0:0 S I=$O(^DG(405.1,"AT",6,I)) Q:'I I $D(^DG(405.1,I,0)),$P(^(0),"^",4) S C=C+1,DGPMSPI=I I C>1 K DGPMSPI Q
Q
;
SPEC ; -- entry point to add/edit specialty mvt when adding/editing
; a physical mvt
;
; Input: Y = ifn of mvt file ^ auto add specialty entry(1)
; Output: Y = ifn of spec mvt
;
; Variable: DGPMPHY = physical mvt IFN ; DGPMPHY0 = 0th node
; DGPMSP = specialty mvt IFN
;
Q:'$D(^DGPM(+Y,0))
N DGPMT,DGPMN S DGPMPHY=+Y,DGPMPHY0=^DGPM(+Y,0),DGPMT=6,DGPMN=0
S DGPMSP=$S($D(^DGPM("APHY",DGPMPHY)):$O(^(DGPMPHY,0)),1:"")
I 'DGPMSP S Y=+$P(Y,"^",2) D ASK:'Y G SPECQ:'Y D NEW
D EDIT:DGPMSP
SPECQ S Y=DGPMSP K DGPMPHY,DGPMPHY0,DGPMSP Q
;
ASK ; -- ask user if they want to make a special mvt also
W ! S DIR(0)="YA",DIR("A")="Do you wish to associate a 'facility treating specialty' transfer? "
S DIR("?",1)="If you would like to associate a facility specialty"
S DIR("?",2)="transfer with this physical movement than answer 'Yes'."
S DIR("?")="Otherwise, answer with a 'No'."
D ^DIR K DIR
Q
;
NEW ; -- add a specialty mvt
S X=DGPMPHY0,Y=+X_U_DGPMT_U_$P(X,U,3),$P(Y,U,14)=$P(X,U,14),$P(Y,U,24)=DGPMPHY
S X=+X,DGPM0ND=Y D NEW^DGPMV3
S DGPMSP=$S(+Y>0:+Y,1:"") S DGPMN=(+Y>0)
;I DGPMSP,$P(DGPMPHY0,"^",2)=1,$P(DGPMPHY0,"^",10)]"" S DR="99///"_$P(DGPMPHY0,"^",10),DA=DGPMSP,DIE="^DGPM(" D ^DIE ;IHS/ANMC/LJF 7/6/2001
K DIE,DIC,DA,DR,DGPM0ND
Q
EDIT ; -- edit specialty mvt
N DGPMX,DGPMP
I DGPMN S (DGPMP,^UTILITY("DGPM",$J,6,DGPMSP,"P"))="",DIE("NO^")=""
I 'DGPMN S (DGPMP,^UTILITY("DGPM",$J,6,DGPMSP,"P"))=^DGPM(DGPMSP,0)
;
;IHS/ANMC/LJF 3/09/2001 add IHS ^utility nodes
I DGPMN S ^UTILITY("DGPM",$J,6,DGPMSP,"IHSP")=""
I 'DGPMN S ^UTILITY("DGPM",$J,6,DGPMSP,"IHSP")=$G(^DGPM(DGPMSP,"IHS"))
;IHS/ANMC/LJF 3/09/2001 end of changes
;
S Y=DGPMSP D PRIOR
S DGPMN=(+DGPMP=+DGPMPHY0) ;set to 1 no dt/time change to bypass x-refs
;
;IHS/ANMC/LJF 2/21/2001 changed to IHS input template
;S DGPMX=+DGPMPHY0,DA=DGPMSP,DIE="^DGPM(",DR="[DGPM SPECIALTY TRANSFER]"
S DGPMX=+DGPMPHY0,DA=DGPMSP,DIE="^DGPM(",DR="[BDGPM SPECIALTY TRANSFER]"
I $G(BDGAPI) S DR="[BDGPM SPECIALTY TRANSFER API]" ;IHS/ANMC/LJF 7/25/2001
;IHS/ANMC/LJF 2/21/2001 end of change
;
K DQ,DG D ^DIE
S ^UTILITY("DGPM",$J,6,DGPMSP,"A")=$S($D(^DGPM(DGPMSP,0)):^(0),1:"")
S ^UTILITY("DGPM",$J,6,DGPMSP,"IHSA")=$G(^DGPM(DGPMSP,"IHS")) ;IHS/ANMC/LJF 3/09/2001
S Y=DGPMSP D AFTER
Q
;
PRIOR ; -- set special 'prior' nodes for event driver
I DGPMN S (^UTILITY("DGPM",$J,6,Y,"DXP"),^("PTFP"))=""
I 'DGPMN S X=$P($S($D(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4),X=X_$S($D(^(1,0)):$E(^(0),1,245-$L(X)),1:""),^UTILITY("DGPM",$J,6,Y,"DXP")=X,^UTILITY("DGPM",$J,6,Y,"PTFP")=$S($D(^DGPM(Y,"PTF")):^("PTF"),1:"")
Q
;
AFTER ; -- set special 'after' nodes for event driver
S X=$P($S($D(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4),X=X_$S($D(^(1,0)):$E(^(0),1,245-$L(X)),1:""),^UTILITY("DGPM",$J,6,Y,"DXA")=X,^UTILITY("DGPM",$J,6,Y,"PTFA")=$S($D(^DGPM(Y,"PTF")):^("PTF"),1:"")
Q
DGPMV36 ;ALB/MIR - TREATING SPECIALTY TRANSFER, CONTINUED ; [ 03/15/2002 10:14 AM ]
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 2/21/2001 Used IHS input templates
+3 ; 3/09/2001 Added IHS ^utility nodes for event driver
+4 ; 7/06/2001 Removed stuffing of DX into comments
+5 ; 7/25/2001 Added check for silent API
+6 ; 7/26/2001 Added check for DGQUIET to write statements
+7 ;
+8 ;I '$P(DGPMA,"^",9) S DGPMA="",DIK="^DGPM(",DA=DGPMDA D ^DIK K DIK W !,"Incomplete Treating Specialty Transfer...Deleted" ;IHS/ANMC/LJF 7/26/2001
+9 ;IHS/ANMC/LJF 7/26/2001
IF '$PIECE(DGPMA,"^",9)
SET DGPMA=""
SET DIK="^DGPM("
SET DA=DGPMDA
DO ^DIK
KILL DIK
IF '$DATA(DGQUIET)
WRITE !,"Incomplete Treating Specialty Transfer...Deleted"
+10 QUIT
+11 ;
DICS ; -- check that it is a PROVIDER/SPECIALTY change
+1 SET DGER=DGPMTYP'=20
+2 QUIT
+3 ;
ONLY ; -- determine if there is only one 'specialty xfr' type mvt
+1 NEW C,I
SET C=0
+2 FOR I=0:0
SET I=$ORDER(^DG(405.1,"AT",6,I))
IF 'I
QUIT
IF $DATA(^DG(405.1,I,0))
IF $PIECE(^(0),"^",4)
SET C=C+1
SET DGPMSPI=I
IF C>1
KILL DGPMSPI
QUIT
+3 QUIT
+4 ;
SPEC ; -- entry point to add/edit specialty mvt when adding/editing
+1 ; a physical mvt
+2 ;
+3 ; Input: Y = ifn of mvt file ^ auto add specialty entry(1)
+4 ; Output: Y = ifn of spec mvt
+5 ;
+6 ; Variable: DGPMPHY = physical mvt IFN ; DGPMPHY0 = 0th node
+7 ; DGPMSP = specialty mvt IFN
+8 ;
+9 IF '$DATA(^DGPM(+Y,0))
QUIT
+10 NEW DGPMT,DGPMN
SET DGPMPHY=+Y
SET DGPMPHY0=^DGPM(+Y,0)
SET DGPMT=6
SET DGPMN=0
+11 SET DGPMSP=$SELECT($DATA(^DGPM("APHY",DGPMPHY)):$ORDER(^(DGPMPHY,0)),1:"")
+12 IF 'DGPMSP
SET Y=+$PIECE(Y,"^",2)
IF 'Y
DO ASK
IF 'Y
GOTO SPECQ
DO NEW
+13 IF DGPMSP
DO EDIT
SPECQ SET Y=DGPMSP
KILL DGPMPHY,DGPMPHY0,DGPMSP
QUIT
+1 ;
ASK ; -- ask user if they want to make a special mvt also
+1 WRITE !
SET DIR(0)="YA"
SET DIR("A")="Do you wish to associate a 'facility treating specialty' transfer? "
+2 SET DIR("?",1)="If you would like to associate a facility specialty"
+3 SET DIR("?",2)="transfer with this physical movement than answer 'Yes'."
+4 SET DIR("?")="Otherwise, answer with a 'No'."
+5 DO ^DIR
KILL DIR
+6 QUIT
+7 ;
NEW ; -- add a specialty mvt
+1 SET X=DGPMPHY0
SET Y=+X_U_DGPMT_U_$PIECE(X,U,3)
SET $PIECE(Y,U,14)=$PIECE(X,U,14)
SET $PIECE(Y,U,24)=DGPMPHY
+2 SET X=+X
SET DGPM0ND=Y
DO NEW^DGPMV3
+3 SET DGPMSP=$SELECT(+Y>0:+Y,1:"")
SET DGPMN=(+Y>0)
+4 ;I DGPMSP,$P(DGPMPHY0,"^",2)=1,$P(DGPMPHY0,"^",10)]"" S DR="99///"_$P(DGPMPHY0,"^",10),DA=DGPMSP,DIE="^DGPM(" D ^DIE ;IHS/ANMC/LJF 7/6/2001
+5 KILL DIE,DIC,DA,DR,DGPM0ND
+6 QUIT
EDIT ; -- edit specialty mvt
+1 NEW DGPMX,DGPMP
+2 IF DGPMN
SET (DGPMP,^UTILITY("DGPM",$JOB,6,DGPMSP,"P"))=""
SET DIE("NO^")=""
+3 IF 'DGPMN
SET (DGPMP,^UTILITY("DGPM",$JOB,6,DGPMSP,"P"))=^DGPM(DGPMSP,0)
+4 ;
+5 ;IHS/ANMC/LJF 3/09/2001 add IHS ^utility nodes
+6 IF DGPMN
SET ^UTILITY("DGPM",$JOB,6,DGPMSP,"IHSP")=""
+7 IF 'DGPMN
SET ^UTILITY("DGPM",$JOB,6,DGPMSP,"IHSP")=$GET(^DGPM(DGPMSP,"IHS"))
+8 ;IHS/ANMC/LJF 3/09/2001 end of changes
+9 ;
+10 SET Y=DGPMSP
DO PRIOR
+11 ;set to 1 no dt/time change to bypass x-refs
SET DGPMN=(+DGPMP=+DGPMPHY0)
+12 ;
+13 ;IHS/ANMC/LJF 2/21/2001 changed to IHS input template
+14 ;S DGPMX=+DGPMPHY0,DA=DGPMSP,DIE="^DGPM(",DR="[DGPM SPECIALTY TRANSFER]"
+15 SET DGPMX=+DGPMPHY0
SET DA=DGPMSP
SET DIE="^DGPM("
SET DR="[BDGPM SPECIALTY TRANSFER]"
+16 ;IHS/ANMC/LJF 7/25/2001
IF $GET(BDGAPI)
SET DR="[BDGPM SPECIALTY TRANSFER API]"
+17 ;IHS/ANMC/LJF 2/21/2001 end of change
+18 ;
+19 KILL DQ,DG
DO ^DIE
+20 SET ^UTILITY("DGPM",$JOB,6,DGPMSP,"A")=$SELECT($DATA(^DGPM(DGPMSP,0)):^(0),1:"")
+21 ;IHS/ANMC/LJF 3/09/2001
SET ^UTILITY("DGPM",$JOB,6,DGPMSP,"IHSA")=$GET(^DGPM(DGPMSP,"IHS"))
+22 SET Y=DGPMSP
DO AFTER
+23 QUIT
+24 ;
PRIOR ; -- set special 'prior' nodes for event driver
+1 IF DGPMN
SET (^UTILITY("DGPM",$JOB,6,Y,"DXP"),^("PTFP"))=""
+2 IF 'DGPMN
SET X=$PIECE($SELECT($DATA(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4)
SET X=X_$SELECT($DATA(^(1,0)):$EXTRACT(^(0),1,245-$LENGTH(X)),1:"")
SET ^UTILITY("DGPM",$JOB,6,Y,"DXP")=X
SET ^UTILITY("DGPM",$JOB,6,Y,"PTFP")=$SELECT($DATA(^DGPM(Y,"PTF")):^("PTF"),1:"")
+3 QUIT
+4 ;
AFTER ; -- set special 'after' nodes for event driver
+1 SET X=$PIECE($SELECT($DATA(^DGPM(Y,"DX",0)):^(0),1:""),"^",3,4)
SET X=X_$SELECT($DATA(^(1,0)):$EXTRACT(^(0),1,245-$LENGTH(X)),1:"")
SET ^UTILITY("DGPM",$JOB,6,Y,"DXA")=X
SET ^UTILITY("DGPM",$JOB,6,Y,"PTFA")=$SELECT($DATA(^DGPM(Y,"PTF")):^("PTF"),1:"")
+2 QUIT
