- PXRMLPOE ;SLC/PJH,PKR - Build OE/RR Team from Patient List ;02/21/2014
- ;;2.0;CLINICAL REMINDERS;**4,24,26**;Feb 04, 2005;Build 404
- ;
- ; Called from PXRM PATIENT LIST OE/RR protocol
- ASK(PLIEN,OPT) ;Verify patient list name
- N DIR,X,Y,TEXT
- K DIROUT,DIRUT,DTOUT,DUOUT
- S DIR(0)="YA0"
- S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
- S DIR("B")="N"
- S DIR("?")="Enter Y or N. For detailed help type ??"
- W !
- D ^DIR K DIR
- I $D(DIROUT) S DTOUT=1
- I $D(DTOUT)!($D(DUOUT)) Q
- I $E(Y(0))="N" S DUOUT=1 Q
- Q
- ;
- LOCK(LIST) ;Lock the list
- L +^PXRMXP(100.21,LIST):DILOCKTM
- E W !!?5,"Another user is using this OE/RR team list" S DUOUT=1
- Q
- ;
- OERR(IENO) ;Copy patient list to OE/RR Team
- ;Check if OK to copy
- D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
- ;
- N IENN,NNAME,ONAME,TEXT,X,Y
- ;
- ;Select OE/RR Team to copy to
- S TEXT="Select OE/RR TEAM name to copy to: "
- D OTEAM(.IENN,.NNAME,TEXT) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN
- ;
- S ONAME=$P($G(^PXRMXP(810.5,IENO,0)),U)
- ;
- ;Update OE/RR Team list
- D UPDLST(IENO,IENN,NNAME)
- Q
- ;
- OK ;Option to overwrite existing list
- N X,Y,TEXT
- K DIROUT,DIRUT,DTOUT,DUOUT
- S DIR(0)="YA0"
- S DIR("A")="Overwrite existing OE/RR Team list: "
- S DIR("B")="N"
- S DIR("?")="Enter Y or N. For detailed help type ??"
- S DIR("??")=U_"D HELP^PXRMLCR(1)"
- W !
- D ^DIR K DIR
- I $D(DIROUT) S DTOUT=1
- I $D(DTOUT)!($D(DUOUT)) Q
- I $E(Y(0))="N" S DUOUT=1 Q
- Q
- ;
- OTEAM(LIST,NAME,TEXT) ;Select OERR/Team
- N X,Y,DIC,DIE,DR,DLAYGO
- W !
- W !,"To overwrite an existing list you must be the creator of the list and"
- W !,"the OE/RR team list must be defined as a Team List."
- OT1 S DIC=100.21,DLAYGO=DIC,DIC(0)="QAEMZL"
- S DIC("S")="I $P($G(^(0)),U,2)=""TM"",$P($G(^(0)),U,5)=DUZ"
- S DIC("A")=TEXT
- W !
- D ^DIC
- I X="" W !,"An OE/RR Team name must be entered" G OT1
- I X=(U_U) S DTOUT=1
- I Y=-1 S DUOUT=1
- I $D(DTOUT)!$D(DUOUT) Q
- ;
- ;Check if OK to overwrite
- I $P(Y,U,3)'=1 D Q:$D(DTOUT) G:$D(DUOUT) OT1
- .D OK
- ;Return list ien
- S LIST=$P(Y,U),NAME=$P(Y,U,2)
- Q
- ;
- UPDLST(IENO,LIST,NAME) ;Update patient list
- N CNT,DA,DFN,DIK,DUOUT,FDA,FDAIEN,IEN,MSG,SUB,TEMP
- ;Lock patient list
- D LOCK(LIST) Q:$D(DUOUT)
- ;
- ;Clear existing list
- S SUB=0
- F S SUB=$O(^OR(100.21,LIST,10,SUB)) Q:'SUB D
- . S DA=SUB,DA(1)=LIST,DIK="^OR(100.21,"_DA(1)_",10,"
- . D ^DIK
- ;
- ;DBIA #4561 covers putting data into OE/RR list.
- ;Create the stub in file #100.21
- W !,"Updating "_NAME
- S FDA(100.21,"?1,",.01)=NAME
- S FDA(100.21,"?1,",.1)=$$UP^XLFSTR(NAME)
- S FDA(100.21,"?1,",1)="TM"
- S FDA(100.21,"?1,",1.6)=DUZ
- S FDA(100.21,"?1,",1.65)=$$NOW^XLFDT
- S FDA(100.21,"?1,",11)="0"
- D UPDATE^DIE("","FDA","FDAIEN","MSG")
- ;Error
- I $D(MSG) D Q
- . N TEXT
- . S TEXT(1)="The patient list copy failed."
- . S TEXT(2)="Examine the following error message for the reason."
- . S TEXT(3)=""
- . D MES^XPDUTL(.TEXT)
- . D AWRITE^PXRMUTIL("MSG")
- . W ! H 3
- . D UNLOCK(LIST)
- ;Do a direct copy of the patients.
- S (CNT,SUB)=0,IEN=FDAIEN(1)
- F S SUB=$O(^PXRMXP(810.5,IENO,30,SUB)) Q:'SUB D
- . S DFN=$P($G(^PXRMXP(810.5,IENO,30,SUB,0)),U,1) Q:'DFN
- . S CNT=CNT+1
- . S TEMP=DFN_";DPT("
- . S ^OR(100.21,IEN,10,CNT,0)=TEMP
- . S ^OR(100.21,IEN,10,"B",TEMP,CNT)=""
- . S ^OR(100.21,"AB",TEMP,IEN,CNT)=""
- S ^OR(100.21,IEN,10,0)="^100.2101AV"_U_CNT_U_CNT
- ;Unlock patient list
- D UNLOCK(LIST)
- W !!,"Completed copy of patient list '"_ONAME_"'"
- W !,"into OE/RR Team '"_NNAME_"'",! H 3
- Q
- ;
- UNLOCK(LIST) ;Unlock the list
- L -^PXRMXP(100.21,LIST)
- Q
- ;
- PXRMLPOE ;SLC/PJH,PKR - Build OE/RR Team from Patient List ;02/21/2014
- +1 ;;2.0;CLINICAL REMINDERS;**4,24,26**;Feb 04, 2005;Build 404
- +2 ;
- +3 ; Called from PXRM PATIENT LIST OE/RR protocol
- ASK(PLIEN,OPT) ;Verify patient list name
- +1 NEW DIR,X,Y,TEXT
- +2 KILL DIROUT,DIRUT,DTOUT,DUOUT
- +3 SET DIR(0)="YA0"
- +4 SET DIR("A")=OPT_" patient list "_$PIECE($GET(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
- +5 SET DIR("B")="N"
- +6 SET DIR("?")="Enter Y or N. For detailed help type ??"
- +7 WRITE !
- +8 DO ^DIR
- KILL DIR
- +9 IF $DATA(DIROUT)
- SET DTOUT=1
- +10 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +11 IF $EXTRACT(Y(0))="N"
- SET DUOUT=1
- QUIT
- +12 QUIT
- +13 ;
- LOCK(LIST) ;Lock the list
- +1 LOCK +^PXRMXP(100.21,LIST):DILOCKTM
- +2 IF '$TEST
- WRITE !!?5,"Another user is using this OE/RR team list"
- SET DUOUT=1
- +3 QUIT
- +4 ;
- OERR(IENO) ;Copy patient list to OE/RR Team
- +1 ;Check if OK to copy
- +2 DO ASK(IENO,"Copy")
- IF $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +3 ;
- +4 NEW IENN,NNAME,ONAME,TEXT,X,Y
- +5 ;
- +6 ;Select OE/RR Team to copy to
- +7 SET TEXT="Select OE/RR TEAM name to copy to: "
- +8 DO OTEAM(.IENN,.NNAME,TEXT)
- IF $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- IF 'IENN
- QUIT
- +9 ;
- +10 SET ONAME=$PIECE($GET(^PXRMXP(810.5,IENO,0)),U)
- +11 ;
- +12 ;Update OE/RR Team list
- +13 DO UPDLST(IENO,IENN,NNAME)
- +14 QUIT
- +15 ;
- OK ;Option to overwrite existing list
- +1 NEW X,Y,TEXT
- +2 KILL DIROUT,DIRUT,DTOUT,DUOUT
- +3 SET DIR(0)="YA0"
- +4 SET DIR("A")="Overwrite existing OE/RR Team list: "
- +5 SET DIR("B")="N"
- +6 SET DIR("?")="Enter Y or N. For detailed help type ??"
- +7 SET DIR("??")=U_"D HELP^PXRMLCR(1)"
- +8 WRITE !
- +9 DO ^DIR
- KILL DIR
- +10 IF $DATA(DIROUT)
- SET DTOUT=1
- +11 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +12 IF $EXTRACT(Y(0))="N"
- SET DUOUT=1
- QUIT
- +13 QUIT
- +14 ;
- OTEAM(LIST,NAME,TEXT) ;Select OERR/Team
- +1 NEW X,Y,DIC,DIE,DR,DLAYGO
- +2 WRITE !
- +3 WRITE !,"To overwrite an existing list you must be the creator of the list and"
- +4 WRITE !,"the OE/RR team list must be defined as a Team List."
- OT1 SET DIC=100.21
- SET DLAYGO=DIC
- SET DIC(0)="QAEMZL"
- +1 SET DIC("S")="I $P($G(^(0)),U,2)=""TM"",$P($G(^(0)),U,5)=DUZ"
- +2 SET DIC("A")=TEXT
- +3 WRITE !
- +4 DO ^DIC
- +5 IF X=""
- WRITE !,"An OE/RR Team name must be entered"
- GOTO OT1
- +6 IF X=(U_U)
- SET DTOUT=1
- +7 IF Y=-1
- SET DUOUT=1
- +8 IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +9 ;
- +10 ;Check if OK to overwrite
- +11 IF $PIECE(Y,U,3)'=1
- Begin DoDot:1
- +12 DO OK
- End DoDot:1
- IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- GOTO OT1
- +13 ;Return list ien
- +14 SET LIST=$PIECE(Y,U)
- SET NAME=$PIECE(Y,U,2)
- +15 QUIT
- +16 ;
- UPDLST(IENO,LIST,NAME) ;Update patient list
- +1 NEW CNT,DA,DFN,DIK,DUOUT,FDA,FDAIEN,IEN,MSG,SUB,TEMP
- +2 ;Lock patient list
- +3 DO LOCK(LIST)
- IF $DATA(DUOUT)
- QUIT
- +4 ;
- +5 ;Clear existing list
- +6 SET SUB=0
- +7 FOR
- SET SUB=$ORDER(^OR(100.21,LIST,10,SUB))
- IF 'SUB
- QUIT
- Begin DoDot:1
- +8 SET DA=SUB
- SET DA(1)=LIST
- SET DIK="^OR(100.21,"_DA(1)_",10,"
- +9 DO ^DIK
- End DoDot:1
- +10 ;
- +11 ;DBIA #4561 covers putting data into OE/RR list.
- +12 ;Create the stub in file #100.21
- +13 WRITE !,"Updating "_NAME
- +14 SET FDA(100.21,"?1,",.01)=NAME
- +15 SET FDA(100.21,"?1,",.1)=$$UP^XLFSTR(NAME)
- +16 SET FDA(100.21,"?1,",1)="TM"
- +17 SET FDA(100.21,"?1,",1.6)=DUZ
- +18 SET FDA(100.21,"?1,",1.65)=$$NOW^XLFDT
- +19 SET FDA(100.21,"?1,",11)="0"
- +20 DO UPDATE^DIE("","FDA","FDAIEN","MSG")
- +21 ;Error
- +22 IF $DATA(MSG)
- Begin DoDot:1
- +23 NEW TEXT
- +24 SET TEXT(1)="The patient list copy failed."
- +25 SET TEXT(2)="Examine the following error message for the reason."
- +26 SET TEXT(3)=""
- +27 DO MES^XPDUTL(.TEXT)
- +28 DO AWRITE^PXRMUTIL("MSG")
- +29 WRITE !
- HANG 3
- +30 DO UNLOCK(LIST)
- End DoDot:1
- QUIT
- +31 ;Do a direct copy of the patients.
- +32 SET (CNT,SUB)=0
- SET IEN=FDAIEN(1)
- +33 FOR
- SET SUB=$ORDER(^PXRMXP(810.5,IENO,30,SUB))
- IF 'SUB
- QUIT
- Begin DoDot:1
- +34 SET DFN=$PIECE($GET(^PXRMXP(810.5,IENO,30,SUB,0)),U,1)
- IF 'DFN
- QUIT
- +35 SET CNT=CNT+1
- +36 SET TEMP=DFN_";DPT("
- +37 SET ^OR(100.21,IEN,10,CNT,0)=TEMP
- +38 SET ^OR(100.21,IEN,10,"B",TEMP,CNT)=""
- +39 SET ^OR(100.21,"AB",TEMP,IEN,CNT)=""
- End DoDot:1
- +40 SET ^OR(100.21,IEN,10,0)="^100.2101AV"_U_CNT_U_CNT
- +41 ;Unlock patient list
- +42 DO UNLOCK(LIST)
- +43 WRITE !!,"Completed copy of patient list '"_ONAME_"'"
- +44 WRITE !,"into OE/RR Team '"_NNAME_"'",!
- HANG 3
- +45 QUIT
- +46 ;
- UNLOCK(LIST) ;Unlock the list
- +1 LOCK -^PXRMXP(100.21,LIST)
- +2 QUIT
- +3 ;