ACMTRANS ; IHS/TUCSON/TMJ - CONTROL TRANSFER OF PATIENTS TO CMS ; [ 02/19/2002 12:14 PM ]
;;2.0;ACM CASE MANAGEMENT SYSTEM;**5**;JAN 10, 1996
;UTILITY TO TRANSFER CLIENTS FROM PCC REGISTERS, TAXONOMIES AND
;SEARCH TEMPLATES TO THE CMS
;;EP;ENTRY POINT
EN D SLCT
D PCC:'$D(ACMQUIT)&$D(ACMSLCT)
EXIT K ACMRG,ACMRGNA,ACMU,ACMTRN,ACMTRNA,ACMTRNX,ACMRGTP,ACMX,ACMI,ACMSLCT
K ACMQUIT,ACM1,ACM2,ACM3,ACMGLB,ACMGLB1
Q
;
SLCT ;D HEAD^ACMMENU
SLCT1 S ACMX="DATA TRANSFER UTILITY",ACM1="Transfer from PCC REGISTER",ACM2="Transfer from PATIENT TAXONOMY",ACM3="Transfer from SEARCH TEMPLATE"
;W !!,?80-$L(ACMX)\2,ACMX,!! K ACMX
;F X=1,2,3 W !?14,X,") ",@("ACM"_X)
W !!
;S DIR(0)="NOA^1:3",DIR("A")="Transfer option ==> ",DIR("?",1)="Type '1' for PCC Transfer,",DIR("?",2)=" '2' for Patient Taxonomy",DIR("?")=" or '3' for Search Template."
;D ^DIR K DIR
;I Y<1 S ACMQUIT="" Q
S Y=3
S ACMSLCT=$S(Y=1:"PCC",Y=3:"SER",1:"TAX"),ACMTRN=Y
Q
;
PCC D HEAD^ACMMENU
S ACMX="ACM"_ACMTRN
W !!,?80-$L(@ACMX)\2,@ACMX,!! K ACMX,ACMTRN
I ACMSLCT="SER" D TLOOK G:Y<1 EXIT G TRX
S ACMX(5)="W:ACMJ#2=1 !?14 W:ACMJ#2=0 ?45 W ACMTRNX",ACMTRNX="",ACMGLB1=$S(ACMSLCT="PCC":"^APCRREG(""B"")",1:"^ATXAX(""B"")"),ACMGLB=$S(ACMSLCT="PCC":"^APCRREG(",1:"^ATXAX(")
F ACMJ=1:1 S ACMTRNX=$O(@ACMGLB1@(ACMTRNX)) Q:ACMTRNX="" S ACMTRN="",ACMTRN=$O(@ACMGLB1@(ACMTRNX,ACMTRN)) X ACMX(5)
PCCO S DIC=ACMGLB,DIC(0)="AEMQ",DIC("A")=$S(ACMSLCT="PCC":"PCC REGISTER: ",1:" TAXONOMY: ")
D ^DIC K DIC
Q:Y<1
S ACMTRN=+Y,ACMTRNA=$P(Y,U,2),ACMRGTP=""
W !
TRX D RGTPX^ACMGTP
I '$D(ACMRG) K ACMRG,ACMRGNA,ACMRGTP,ACMTRNX,ACMTRN,ACMJ,ACMX Q
STATUS ;get status to transfer
S DIR(0)="S^A:ACTIVE;I:INACTIVE;U:UNREVIEWED",DIR("A")="Enter Patient Transfer Status",DIR("B")="A",DIR("?")="Enter the status that will be assigned to the patient when transfered."
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
S ACMSTAT=Y,ACMSTAT(0)=Y(0)
W !!?10,"The following transfer has been selected:",!!?10,"From ",$S(ACMSLCT="PCC":"PCC register: ",ACMSLCT="SER":"SEARCH TEMPLATE: ",1:" PT TAXONOMY: ")
W ?30,ACMTRNA,!?12,"To CMS register:",?30,ACMRGNA,!?10,"Transfer Status: ",?30,ACMSTAT," - ",ACMSTAT(0),!!,?10,"Is that what you want"
S %=2 D YN^DICN
I %<1!(%=2) D EXIT Q
I %=1 D TSK
MESS W !!?10,"Transfer of patients will be done in background mode.",!?10,"All patients will be entered as "_ACMSTAT(0),". All cases",!?10,"should be reviewed and all patient data updated in the",!?10,@ACMRVON,ACMRGNA,@ACMRVOFF," register."
W !
D PAUSE^ACMMENU
Q
TRANS S $P(^ACM(41.1,ACMRG,0),U,9)=1,ACMU=$S(ACMSLCT="PCC":"",1:0),ACMGLB=$S(ACMSLCT="PCC":"^APCRREG("_ACMTRN_",1,""B"")",ACMSLCT="SER":"^DIBT("_ACMTRN_",1)",1:"^ATXPAT("_ACMTRN_",11)")
F S ACMU=$O(@ACMGLB@(ACMU)) Q:ACMU="" D:'$D(^ACM(41,"AC",ACMU,ACMRG)) MOVE
S $P(^ACM(41.1,ACMRG,0),U,9)=""
K ACMRG,ACMRGNA,ACMU,ACMTRN,ACMTRNA,ACMTRNX,ACMRGTP,ACMX,ACMI,ACMSLCT,DIC,DIE,DA,DR,DD
S ZTREQ="@"
Q
MOVE Q:$D(^ACM(41,"AC",ACMU,ACMRG))
S:$P(^ACM(41.1,ACMRG,0),U,9)="" $P(^(0),U,9)=1
S DIC="^ACM(41,",DIC(0)="L",DIC("DR")=".02////"_ACMU_";1////"_ACMSTAT_";2////"_DT_";4////"_DT,X=ACMRG
K DD,DO D FILE^DICN K DIC,DA,DR,DIE
D DECEASED^ACMLPAT(ACMU,+Y) ;IHS/CIM/THL PATCH 5
Q
TSK S ZTRTN="TRANS^ACMTRANS",ZTDESC="TRANSFER PCC REGISTER OR TAXONOMY DATA TO CMS REGISTER",ZTSAVE("ACM*")="",ZTIO="",ZTDTH=$H
D ^%ZTLOAD
Q
TLOOK K DIC
;S DIC="^DIBT(",DIC(0)="AEQZ",DIC("A")="Select SEARCH TEMPLATE: ",DIC("S")="I (($P(^(0),U,4)=2!($P(^(0),U,4)=9000001))) Q:'$D(DS(2)) I $D(^DIBT(DS(2),1))"
S DIC="^DIBT(",DIC(0)="AEQZ",DIC("A")="Select SEARCH TEMPLATE: ",DIC("S")="I ($P(^(0),U,4)=2!($P(^(0),U,4)=9000001)),$D(^DIBT(+$G(Y),1))" ;IHS/CIM/THL/PATCH 5
D ^DIC K DIC,DA,DR
Q:+Y<1
W !
S ACMTRN=+Y,ACMTRNA=$P(Y,U,2),(ACMRGTP,ACMI)=""
F ACMYI=1:1 S ACMI=$O(^DIBT(ACMTRN,1,ACMI)) Q:ACMI=""
W !!?10,"There are ",ACMYI-1," patients in this SEARCH TEMPLATE."
K ACMI,ACMYI
W !
S ACMYI=0
F S ACMYI=$O(^DIBT(ACMTRN,"%D",ACMYI)) Q:'ACMYI W !,?3,^(ACMYI,0)
K ACMYI
W !
Q
ACMTRANS ; IHS/TUCSON/TMJ - CONTROL TRANSFER OF PATIENTS TO CMS ; [ 02/19/2002 12:14 PM ]
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**5**;JAN 10, 1996
+2 ;UTILITY TO TRANSFER CLIENTS FROM PCC REGISTERS, TAXONOMIES AND
+3 ;SEARCH TEMPLATES TO THE CMS
+4 ;;EP;ENTRY POINT
EN DO SLCT
+1 IF '$DATA(ACMQUIT)&$DATA(ACMSLCT)
DO PCC
EXIT KILL ACMRG,ACMRGNA,ACMU,ACMTRN,ACMTRNA,ACMTRNX,ACMRGTP,ACMX,ACMI,ACMSLCT
+1 KILL ACMQUIT,ACM1,ACM2,ACM3,ACMGLB,ACMGLB1
+2 QUIT
+3 ;
SLCT ;D HEAD^ACMMENU
SLCT1 SET ACMX="DATA TRANSFER UTILITY"
SET ACM1="Transfer from PCC REGISTER"
SET ACM2="Transfer from PATIENT TAXONOMY"
SET ACM3="Transfer from SEARCH TEMPLATE"
+1 ;W !!,?80-$L(ACMX)\2,ACMX,!! K ACMX
+2 ;F X=1,2,3 W !?14,X,") ",@("ACM"_X)
+3 WRITE !!
+4 ;S DIR(0)="NOA^1:3",DIR("A")="Transfer option ==> ",DIR("?",1)="Type '1' for PCC Transfer,",DIR("?",2)=" '2' for Patient Taxonomy",DIR("?")=" or '3' for Search Template."
+5 ;D ^DIR K DIR
+6 ;I Y<1 S ACMQUIT="" Q
+7 SET Y=3
+8 SET ACMSLCT=$SELECT(Y=1:"PCC",Y=3:"SER",1:"TAX")
SET ACMTRN=Y
+9 QUIT
+10 ;
PCC DO HEAD^ACMMENU
+1 SET ACMX="ACM"_ACMTRN
+2 WRITE !!,?80-$LENGTH(@ACMX)\2,@ACMX,!!
KILL ACMX,ACMTRN
+3 IF ACMSLCT="SER"
DO TLOOK
IF Y<1
GOTO EXIT
GOTO TRX
+4 SET ACMX(5)="W:ACMJ#2=1 !?14 W:ACMJ#2=0 ?45 W ACMTRNX"
SET ACMTRNX=""
SET ACMGLB1=$SELECT(ACMSLCT="PCC":"^APCRREG(""B"")",1:"^ATXAX(""B"")")
SET ACMGLB=$SELECT(ACMSLCT="PCC":"^APCRREG(",1:"^ATXAX(")
+5 FOR ACMJ=1:1
SET ACMTRNX=$ORDER(@ACMGLB1@(ACMTRNX))
IF ACMTRNX=""
QUIT
SET ACMTRN=""
SET ACMTRN=$ORDER(@ACMGLB1@(ACMTRNX,ACMTRN))
XECUTE ACMX(5)
PCCO SET DIC=ACMGLB
SET DIC(0)="AEMQ"
SET DIC("A")=$SELECT(ACMSLCT="PCC":"PCC REGISTER: ",1:" TAXONOMY: ")
+1 DO ^DIC
KILL DIC
+2 IF Y<1
QUIT
+3 SET ACMTRN=+Y
SET ACMTRNA=$PIECE(Y,U,2)
SET ACMRGTP=""
+4 WRITE !
TRX DO RGTPX^ACMGTP
+1 IF '$DATA(ACMRG)
KILL ACMRG,ACMRGNA,ACMRGTP,ACMTRNX,ACMTRN,ACMJ,ACMX
QUIT
STATUS ;get status to transfer
+1 SET DIR(0)="S^A:ACTIVE;I:INACTIVE;U:UNREVIEWED"
SET DIR("A")="Enter Patient Transfer Status"
SET DIR("B")="A"
SET DIR("?")="Enter the status that will be assigned to the patient when transfered."
+2 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 SET ACMSTAT=Y
SET ACMSTAT(0)=Y(0)
+5 WRITE !!?10,"The following transfer has been selected:",!!?10,"From ",$SELECT(ACMSLCT="PCC":"PCC register: ",ACMSLCT="SER":"SEARCH TEMPLATE: ",1:" PT TAXONOMY: ")
+6 WRITE ?30,ACMTRNA,!?12,"To CMS register:",?30,ACMRGNA,!?10,"Transfer Status: ",?30,ACMSTAT," - ",ACMSTAT(0),!!,?10,"Is that what you want"
+7 SET %=2
DO YN^DICN
+8 IF %<1!(%=2)
DO EXIT
QUIT
+9 IF %=1
DO TSK
MESS WRITE !!?10,"Transfer of patients will be done in background mode.",!?10,"All patients will be entered as "_ACMSTAT(0),". All cases",!?10,"should be reviewed and all patient data updated in the",!?10,@ACMRVON,ACMRGNA,@ACMRVOFF," register."
+1 WRITE !
+2 DO PAUSE^ACMMENU
+3 QUIT
TRANS SET $PIECE(^ACM(41.1,ACMRG,0),U,9)=1
SET ACMU=$SELECT(ACMSLCT="PCC":"",1:0)
SET ACMGLB=$SELECT(ACMSLCT="PCC":"^APCRREG("_ACMTRN_",1,""B"")",ACMSLCT="SER":"^DIBT("_ACMTRN_",1)",1:"^ATXPAT("_ACMTRN_",11)")
+1 FOR
SET ACMU=$ORDER(@ACMGLB@(ACMU))
IF ACMU=""
QUIT
IF '$DATA(^ACM(41,"AC",ACMU,ACMRG))
DO MOVE
+2 SET $PIECE(^ACM(41.1,ACMRG,0),U,9)=""
+3 KILL ACMRG,ACMRGNA,ACMU,ACMTRN,ACMTRNA,ACMTRNX,ACMRGTP,ACMX,ACMI,ACMSLCT,DIC,DIE,DA,DR,DD
+4 SET ZTREQ="@"
+5 QUIT
MOVE IF $DATA(^ACM(41,"AC",ACMU,ACMRG))
QUIT
+1 IF $PIECE(^ACM(41.1,ACMRG,0),U,9)=""
SET $PIECE(^(0),U,9)=1
+2 SET DIC="^ACM(41,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_ACMU_";1////"_ACMSTAT_";2////"_DT_";4////"_DT
SET X=ACMRG
+3 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DR,DIE
+4 ;IHS/CIM/THL PATCH 5
DO DECEASED^ACMLPAT(ACMU,+Y)
+5 QUIT
TSK SET ZTRTN="TRANS^ACMTRANS"
SET ZTDESC="TRANSFER PCC REGISTER OR TAXONOMY DATA TO CMS REGISTER"
SET ZTSAVE("ACM*")=""
SET ZTIO=""
SET ZTDTH=$HOROLOG
+1 DO ^%ZTLOAD
+2 QUIT
TLOOK KILL DIC
+1 ;S DIC="^DIBT(",DIC(0)="AEQZ",DIC("A")="Select SEARCH TEMPLATE: ",DIC("S")="I (($P(^(0),U,4)=2!($P(^(0),U,4)=9000001))) Q:'$D(DS(2)) I $D(^DIBT(DS(2),1))"
+2 ;IHS/CIM/THL/PATCH 5
SET DIC="^DIBT("
SET DIC(0)="AEQZ"
SET DIC("A")="Select SEARCH TEMPLATE: "
SET DIC("S")="I ($P(^(0),U,4)=2!($P(^(0),U,4)=9000001)),$D(^DIBT(+$G(Y),1))"
+3 DO ^DIC
KILL DIC,DA,DR
+4 IF +Y<1
QUIT
+5 WRITE !
+6 SET ACMTRN=+Y
SET ACMTRNA=$PIECE(Y,U,2)
SET (ACMRGTP,ACMI)=""
+7 FOR ACMYI=1:1
SET ACMI=$ORDER(^DIBT(ACMTRN,1,ACMI))
IF ACMI=""
QUIT
+8 WRITE !!?10,"There are ",ACMYI-1," patients in this SEARCH TEMPLATE."
+9 KILL ACMI,ACMYI
+10 WRITE !
+11 SET ACMYI=0
+12 FOR
SET ACMYI=$ORDER(^DIBT(ACMTRN,"%D",ACMYI))
IF 'ACMYI
QUIT
WRITE !,?3,^(ACMYI,0)
+13 KILL ACMYI
+14 WRITE !
+15 QUIT
