- GMTSDD ; SLC/KCM,KER - Health Summary DD calls ; 02/27/2002
- ;;2.7;Health Summary;**7,49**;Oct 20, 1995
- ;
- ; External References
- ; DBIA 2430 ^XUTL("XQORM")
- ; DBIA 10018 ^DIE (file #142)
- ; DBIA 10104 $$UP^XLFSTR
- ;
- SET ; From: x-ref in 142,99 Entry: DA Exit: DA
- ;
- ; NOTE: Lock ^XUTL("XQORM",XQORM) and
- ; ^GMT(142,DA) before calling
- ;
- N I,J,X,X0,X1,COL,CCOL,IEN,ORD,ROW,TOT,GMNAME
- I $D(^XUTL("XQORM",DA_";GMT(142,",0)),$D(^GMT(142,DA,99)),($P(^GMT(142,DA,99),"^",1)=$P(^XUTL("XQORM",DA_";GMT(142,",0),"^",1)) Q
- K ^TMP("XQORM",$J) D KILL S TOT=0
- S IEN=0 F S IEN=$O(^GMT(142,DA,1,IEN)) Q:IEN'>0 I $D(^GMT(142,DA,1,IEN,0)) S X=^(0) I $D(^GMT(142.1,+$P(X,"^",2),0)),($P(^(0),"^",6)'="P"),($P(^(0),U,6)'="T") S TOT=TOT+1,GMNAME=$P($G(^(0)),U) D ORD
- S COL=$S(TOT\2>20:3,1:2),X=TOT\COL S:TOT#COL X=X+1 S ROW=X,CCOL=.1,^XUTL("XQORM",DA_";GMT(142,","COL")=COL
- S ORD="" F S ORD=$O(^TMP("XQORM",$J,ORD)) Q:ORD="" D
- . S IEN=0 F S IEN=$O(^TMP("XQORM",$J,ORD,IEN)) Q:+IEN'>0 S CCOL=$S((CCOL\1)'<ROW:1+($P(CCOL,".",2)/10)+.1,1:CCOL+1) D BILD
- S X=$H,(^XUTL("XQORM",DA_";GMT(142,",0),^GMT(142,DA,99))=X
- K ^TMP("XQORM",$J) Q
- ORD ; Summary Order
- S ^TMP("XQORM",$J,GMNAME,IEN)=""
- Q
- BILD ; Build XQORM array
- S X0=^GMT(142,DA,1,IEN,0) Q:'$P(X0,"^",2)
- S X1=^GMT(142.1,$P(X0,"^",2),0),X=$S($L($P(X0,U,5)):$P(X0,U,5),$L($P(X1,"^",9)):$P(X1,"^",9),1:$E($P(X1,"^",1),1,19))
- F %=1:1:$L(X) I ",=;-"[$E(X,%) S X=$E(X,1,%-1)_" "_$E(X,%+1,999)
- S ^XUTL("XQORM",DA_";GMT(142,",CCOL,0)=IEN_"^"_$P(X0,"^",1)_"^"_X_"^"_$P(X1,"^",4)
- I $L(X) S X=$$UP^XLFSTR(X),^XUTL("XQORM",DA_";GMT(142,","B",X,CCOL)=""
- S X=$P(X1,"^") I $L(X) S X=$$UP^XLFSTR(X),^XUTL("XQORM",DA_";GMT(142,","B",X,CCOL)=1
- S X=$P(X1,"^",4) I $L(X) S X=$$UP^XLFSTR(X),^XUTL("XQORM",DA_";GMT(142,","B",X,CCOL)=1
- Q
- KILL ; From: x-ref in 142,99 Entry: none Exit: none
- K ^XUTL("XQORM",DA_";GMT(142,")
- Q
- REDO ; From: 142.1,.01 142.1,3 Entry: DA Exit: DA
- N I,X S X=$H S I=0
- F S I=$O(^GMT(142,"AE",DA,I)) Q:I'>0 D
- . I $D(^GMT(142,I,99)) S $P(^(99),"^",1)=X
- Q
- REDOX ; From: 142.01,.01 142.01,1 Entry: DA(1) Exit: DA(1)
- I $D(^GMT(142,DA(1),0)) S ^(99)=$H
- Q
- CLEANUP ; Delete broken pointers from 142.01 to 142.1
- N %,%Y,D0,DI,DIC,DIJ,DIKS,DISYS,DR,DIE,GMDA,GMI,GMJ,X,Y
- S GMDA=+GMCMP,GMI=0 F S GMI=$O(^GMT(142,"AE",GMDA,GMI)) Q:+GMI'>0 D
- . W !,"Deleting pointers from the "_$P(^GMT(142,+GMI,0),U)_" Health Summary Type"
- . S GMJ=0 F S GMJ=$O(^GMT(142,"AE",GMDA,GMI,GMJ)) Q:+GMJ'>0 D
- . . S DIE="^GMT(142,"_GMI_",1,",DR=".01///@",DA=GMJ,DA(1)=GMI D ^DIE W "."
- Q
- CHKNAME ; Called by input transform on ^DD(142.1,.01,0)
- I $D(^GMT(142.1,"B",X)),($G(Y)=-1) D
- . W " Duplicate NAMES not allowed." K X
- Q
- CHKRTN ; Called by input transform on ^DD(142.1,1,0)
- I @("$L($T("_$P(X,";")_U_$P(X,";",2)_"))'>0") D
- . W " Nonexistent ENTRY POINT" K X
- Q
- CHKNUM ; Called by input transform of ^DD(142.1,.001,0)
- I $S('$D(DUZ(2)):0,$G(DUZ(2))'=5000:1,1:0) D
- . I $S(X<100001:1,X>9999999:1,1:0) W " # Out of Range" K X
- Q
- GMTSDD ; SLC/KCM,KER - Health Summary DD calls ; 02/27/2002
- +1 ;;2.7;Health Summary;**7,49**;Oct 20, 1995
- +2 ;
- +3 ; External References
- +4 ; DBIA 2430 ^XUTL("XQORM")
- +5 ; DBIA 10018 ^DIE (file #142)
- +6 ; DBIA 10104 $$UP^XLFSTR
- +7 ;
- SET ; From: x-ref in 142,99 Entry: DA Exit: DA
- +1 ;
- +2 ; NOTE: Lock ^XUTL("XQORM",XQORM) and
- +3 ; ^GMT(142,DA) before calling
- +4 ;
- +5 NEW I,J,X,X0,X1,COL,CCOL,IEN,ORD,ROW,TOT,GMNAME
- +6 IF $DATA(^XUTL("XQORM",DA_";GMT(142,",0))
- IF $DATA(^GMT(142,DA,99))
- IF ($PIECE(^GMT(142,DA,99),"^",1)=$PIECE(^XUTL("XQORM",DA_";GMT(142,",0),"^",1))
- QUIT
- +7 KILL ^TMP("XQORM",$JOB)
- DO KILL
- SET TOT=0
- +8 SET IEN=0
- FOR
- SET IEN=$ORDER(^GMT(142,DA,1,IEN))
- IF IEN'>0
- QUIT
- IF $DATA(^GMT(142,DA,1,IEN,0))
- SET X=^(0)
- IF $DATA(^GMT(142.1,+$PIECE(X,"^",2),0))
- IF ($PIECE(^(0),"^",6)'="P")
- IF ($PIECE(^(0),U,6)'="T")
- SET TOT=TOT+1
- SET GMNAME=$PIECE($GET(^(0)),U)
- DO ORD
- +9 SET COL=$SELECT(TOT\2>20:3,1:2)
- SET X=TOT\COL
- IF TOT#COL
- SET X=X+1
- SET ROW=X
- SET CCOL=.1
- SET ^XUTL("XQORM",DA_";GMT(142,","COL")=COL
- +10 SET ORD=""
- FOR
- SET ORD=$ORDER(^TMP("XQORM",$JOB,ORD))
- IF ORD=""
- QUIT
- Begin DoDot:1
- +11 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("XQORM",$JOB,ORD,IEN))
- IF +IEN'>0
- QUIT
- SET CCOL=$SELECT((CCOL\1)'<ROW:1+($PIECE(CCOL,".",2)/10)+.1,1:CCOL+1)
- DO BILD
- End DoDot:1
- +12 SET X=$HOROLOG
- SET (^XUTL("XQORM",DA_";GMT(142,",0),^GMT(142,DA,99))=X
- +13 KILL ^TMP("XQORM",$JOB)
- QUIT
- ORD ; Summary Order
- +1 SET ^TMP("XQORM",$JOB,GMNAME,IEN)=""
- +2 QUIT
- BILD ; Build XQORM array
- +1 SET X0=^GMT(142,DA,1,IEN,0)
- IF '$PIECE(X0,"^",2)
- QUIT
- +2 SET X1=^GMT(142.1,$PIECE(X0,"^",2),0)
- SET X=$SELECT($LENGTH($PIECE(X0,U,5)):$PIECE(X0,U,5),$LENGTH($PIECE(X1,"^",9)):$PIECE(X1,"^",9),1:$EXTRACT($PIECE(X1,"^",1),1,19))
- +3 FOR %=1:1:$LENGTH(X)
- IF ",=;-"[$EXTRACT(X,%)
- SET X=$EXTRACT(X,1,%-1)_" "_$EXTRACT(X,%+1,999)
- +4 SET ^XUTL("XQORM",DA_";GMT(142,",CCOL,0)=IEN_"^"_$PIECE(X0,"^",1)_"^"_X_"^"_$PIECE(X1,"^",4)
- +5 IF $LENGTH(X)
- SET X=$$UP^XLFSTR(X)
- SET ^XUTL("XQORM",DA_";GMT(142,","B",X,CCOL)=""
- +6 SET X=$PIECE(X1,"^")
- IF $LENGTH(X)
- SET X=$$UP^XLFSTR(X)
- SET ^XUTL("XQORM",DA_";GMT(142,","B",X,CCOL)=1
- +7 SET X=$PIECE(X1,"^",4)
- IF $LENGTH(X)
- SET X=$$UP^XLFSTR(X)
- SET ^XUTL("XQORM",DA_";GMT(142,","B",X,CCOL)=1
- +8 QUIT
- KILL ; From: x-ref in 142,99 Entry: none Exit: none
- +1 KILL ^XUTL("XQORM",DA_";GMT(142,")
- +2 QUIT
- REDO ; From: 142.1,.01 142.1,3 Entry: DA Exit: DA
- +1 NEW I,X
- SET X=$HOROLOG
- SET I=0
- +2 FOR
- SET I=$ORDER(^GMT(142,"AE",DA,I))
- IF I'>0
- QUIT
- Begin DoDot:1
- +3 IF $DATA(^GMT(142,I,99))
- SET $PIECE(^(99),"^",1)=X
- End DoDot:1
- +4 QUIT
- REDOX ; From: 142.01,.01 142.01,1 Entry: DA(1) Exit: DA(1)
- +1 IF $DATA(^GMT(142,DA(1),0))
- SET ^(99)=$HOROLOG
- +2 QUIT
- CLEANUP ; Delete broken pointers from 142.01 to 142.1
- +1 NEW %,%Y,D0,DI,DIC,DIJ,DIKS,DISYS,DR,DIE,GMDA,GMI,GMJ,X,Y
- +2 SET GMDA=+GMCMP
- SET GMI=0
- FOR
- SET GMI=$ORDER(^GMT(142,"AE",GMDA,GMI))
- IF +GMI'>0
- QUIT
- Begin DoDot:1
- +3 WRITE !,"Deleting pointers from the "_$PIECE(^GMT(142,+GMI,0),U)_" Health Summary Type"
- +4 SET GMJ=0
- FOR
- SET GMJ=$ORDER(^GMT(142,"AE",GMDA,GMI,GMJ))
- IF +GMJ'>0
- QUIT
- Begin DoDot:2
- +5 SET DIE="^GMT(142,"_GMI_",1,"
- SET DR=".01///@"
- SET DA=GMJ
- SET DA(1)=GMI
- DO ^DIE
- WRITE "."
- End DoDot:2
- End DoDot:1
- +6 QUIT
- CHKNAME ; Called by input transform on ^DD(142.1,.01,0)
- +1 IF $DATA(^GMT(142.1,"B",X))
- IF ($GET(Y)=-1)
- Begin DoDot:1
- +2 WRITE " Duplicate NAMES not allowed."
- KILL X
- End DoDot:1
- +3 QUIT
- CHKRTN ; Called by input transform on ^DD(142.1,1,0)
- +1 IF @("$L($T("_$PIECE(X,";")_U_$PIECE(X,";",2)_"))'>0")
- Begin DoDot:1
- +2 WRITE " Nonexistent ENTRY POINT"
- KILL X
- End DoDot:1
- +3 QUIT
- CHKNUM ; Called by input transform of ^DD(142.1,.001,0)
- +1 IF $SELECT('$DATA(DUZ(2)):0,$GET(DUZ(2))'=5000:1,1:0)
- Begin DoDot:1
- +2 IF $SELECT(X<100001:1,X>9999999:1,1:0)
- WRITE " # Out of Range"
- KILL X
- End DoDot:1
- +3 QUIT
