ACMTRANS.m

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